From 6a6cbc340b699fe2358c0f1eb48a7f8b3613c5e3 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 25 Sep 2025 18:22:56 -0400 Subject: [PATCH 01/59] refactor: NaturalModel file --- HoTTLean/ForMathlib/CategoryTheory/Grpd.lean | 8 - .../ForMathlib/CategoryTheory/Polynomial.lean | 789 ++++++++++++++ HoTTLean/ForPoly.lean | 1 + HoTTLean/Model/NaturalModel.lean | 988 ++++-------------- HoTTLean/Syntax/Substitution.lean | 5 +- lake-manifest.json | 44 +- lakefile.lean | 2 +- lean-toolchain | 2 +- 8 files changed, 1035 insertions(+), 804 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean index f79625b6..e711784c 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean @@ -34,14 +34,6 @@ instance : CartesianMonoidalCategory Grpd := cone := prodCone X Y isLimit := isLimitProdCone X Y }) -/-- The identity in the category of groupoids equals the identity functor.-/ -theorem id_eq_id (X : Grpd) : 𝟙 X = 𝟭 X := rfl - --- NOTE this is currently called `Grpd.hom_to_functor` in mathlib, --- but this naming is inconsistent with that of `Cat` -/-- Composition in the category of groupoids equals functor composition.-/ -theorem comp_eq_comp {X Y Z : Grpd} (F : X ⟶ Y) (G : Y ⟶ Z) : F ≫ G = F ⋙ G := rfl - theorem eqToHom_obj {C1 C2 : Grpd.{v,u}} (x : C1) (eq : C1 = C2) : (eqToHom eq).obj x = cast (congrArg Bundled.α eq) x := by diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean new file mode 100644 index 00000000..cf76e20d --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -0,0 +1,789 @@ +/- +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 Mathlib.CategoryTheory.MorphismProperty.OverAdjunction +import Mathlib.CategoryTheory.Functor.TwoSquare +import Mathlib.CategoryTheory.NatTrans.IsCartesian +import Mathlib.CategoryTheory.Comma.Over.Pushforward + +universe v u + +noncomputable section + +namespace CategoryTheory + +open Category Limits MorphismProperty + +variable {C : Type u} [Category.{v} C] + +namespace MorphismProperty + +namespace PolynomialPartialAdjunction + +variable {T : Type u} [Category.{v} T] {P : MorphismProperty T} + [P.HasPullbacks] [P.IsStableUnderBaseChange] + {Q : MorphismProperty T} [Q.HasPullbacks] [P.HasPushforwards Q] + [P.IsStableUnderPushforward Q] + {S S' S'' : T} (i : S ⟶ S') (q : S ⟶(Q) S'') + +/-- The partial right adjoint representing a multivariate polynomial. -/ +abbrev partialRightAdjoint := Over.pullback P ⊤ i ⋙ pushforward P q + +abbrev leftAdjoint := CategoryTheory.Over.pullback q.1 ⋙ CategoryTheory.Over.map i + +/-- `pullback P ⊤ i ⋙ pushforward P q` is a partial right adjoint to +`CategoryTheory.Over.pullback q.1 ⋙ CategoryTheory.Over.map i` +-/ +def homEquiv {X : Over S''} {Y : P.Over ⊤ S'} : + (X ⟶ ((partialRightAdjoint i q).obj Y).toComma) ≃ + ((leftAdjoint i q).obj X ⟶ Y.toComma) := + calc (X ⟶ ((P.pushforward q).obj ((Over.pullback P ⊤ i).obj Y)).toComma) + _ ≃ ((CategoryTheory.Over.pullback q.1).obj X ⟶ ((Over.pullback P ⊤ i).obj Y).toComma) := + pushforward.homEquiv .. + _ ≃ ((CategoryTheory.Over.map i).obj + ((CategoryTheory.Over.pullback q.fst).obj X) ⟶ Y.toComma) := + pullback.homEquiv .. + +lemma homEquiv_comp {X X' : Over S''} {Y : P.Over ⊤ S'} + (f : X' ⟶ ((partialRightAdjoint i q).obj Y).toComma) (g : X ⟶ X') : + homEquiv i q (g ≫ f) = + (leftAdjoint i q).map g ≫ homEquiv i q 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 S''} {Y Y' : P.Over ⊤ S'} + (f : X ⟶ ((partialRightAdjoint i q).obj Y).toComma) (g : Y ⟶ Y') : + homEquiv i q (f ≫ Comma.Hom.hom ((partialRightAdjoint i q).map g)) = + homEquiv i q 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 S''} {Y Y' : P.Over ⊤ S'} + (f : (leftAdjoint i q).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : + (homEquiv i q).symm f ≫ Comma.Hom.hom ((partialRightAdjoint i q).map g) = + (homEquiv i q).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 S''} {Y : P.Over ⊤ S'} + (f : (leftAdjoint i q).obj X' ⟶ Y.toComma) (g : X ⟶ X') : + g ≫ (homEquiv i q).symm f = + (homEquiv i q).symm ((leftAdjoint i q).map g ≫ f) := by + unfold homEquiv + simp + erw [pushforward.homEquiv_comp_symm, pullback.homEquiv_comp_symm] + rfl + +def counit : + partialRightAdjoint i q ⋙ Over.forget P ⊤ S'' ⋙ leftAdjoint i q ⟶ Over.forget P ⊤ S' where + app _ := homEquiv i q (𝟙 _) + naturality X Y f := by + apply (homEquiv i q).symm.injective + conv => left; erw [← homEquiv_comp_symm] + conv => right; erw [← homEquiv_symm_comp] + simp + +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 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 : C) where + (E B : C) + (i : E ⟶(R) I) + (p : E ⟶(H) B) + (o : B ⟶(R) O) + +namespace MvPoly + +instance : (⊤ : MorphismProperty C).HasOfPostcompProperty ⊤ where + of_postcomp := by simp + +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 + +variable {I O : C} (P : MvPoly R H I O) [R.HasPullbacks] [R.IsStableUnderBaseChange] + [R.IsStableUnderComposition] [H.HasPullbacks] [R.HasPushforwards H] + [R.IsStableUnderPushforward H] + +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) : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj + +@[inherit_doc] +infix:90 " @ " => apply + +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) (X : R.Over ⊤ I) : R.Over ⊤ P.B := + (partialRightAdjoint P.i.1 P.p).obj X + +@[reassoc (attr := simp)] +lemma map_fstProj (P : MvPoly R H I O) {X Y : R.Over ⊤ I} (f : X ⟶ Y) : + ((partialRightAdjoint P.i.1 P.p).map f).left ≫ (fstProj P Y).hom = (fstProj P X).hom := by + simp + +/-- 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)`. +-/ +def sndProj (P : MvPoly R H I O) (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 + +namespace Equiv + +variable {P : MvPoly R H I O} {Γ : Over O} {X : R.Over ⊤ I} + +def fst (pair : Γ ⟶ (P @ X).toComma) : Over P.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 P.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 P.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 P.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 (P : MvPoly R H I O) : Limits.PreservesLimitsOfShape WalkingCospan + (MorphismProperty.Over.map ⊤ P.o.2) := by sorry + +instance (P : MvPoly R H I O) : + Limits.PreservesLimitsOfShape WalkingCospan (MvPoly.functor P) := by + dsimp [functor] + have : (MorphismProperty.Over.pullback R ⊤ P.i.1).IsRightAdjoint := + Adjunction.isRightAdjoint (MorphismProperty.Over.mapPullbackAdj R ⊤ P.i.1 P.i.2 trivial) + infer_instance + +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 `[HasTerminal 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 [HasTerminal C] + +variable [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] [R.HasObjects] + [R.IsStableUnderPushforward R] [R.HasPushforwards R] + +instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback A P.p := by + let p : E ⟶(R) B := ⟨ P.p, P.morphismProperty ⟩ + convert_to HasPullback A p.1 + apply MorphismProperty.instHasPullbackFstHomOfHasPullbacks + +def object (X : C) : X ⟶(R) ⊤_ C := + ⟨terminal.from X, HasObjects.obj_mem _ terminalIsTerminal⟩ + +@[simp] +abbrev toOverTerminal : C ⥤ R.Over ⊤ (⊤_ C) := + (equivalenceOfHasObjects R terminalIsTerminal).inverse + +@[simp] +abbrev fromOverTerminal : R.Over ⊤ (⊤_ C) ⥤ C := + (equivalenceOfHasObjects R terminalIsTerminal).functor + +@[simps] +def mvPoly (P : UvPoly R E B) : MvPoly R R (⊤_ C) (⊤_ C) where + E := E + B := B + i := object E + p := ⟨P.p, P.morphismProperty⟩ + 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 [HasTerminal C] (P : UvPoly R E B) : C → C := P.functor.obj + +@[inherit_doc] +infix:90 " @ " => apply + +instance [HasTerminal 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 + +open TwoSquare + +/-- A vertical map `ρ : P.p.1 ⟶ Q.p.1` of polynomials (i.e. a commutative triangle) +``` + ρ +E ----> F + \ / + \ / \ / + B +``` +induces a natural transformation `Q.functor ⟶ P.functor ` obtained by pasting the following 2-cells +``` + Q.p.1 +C --- > C/F ----> C/B -----> C +| | | | +| ↙ | ρ* ≅ | = | +| v v | +C --- > C/E ----> C/B ----> C + P.p.1 +``` +-/ +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 := sorry --by + -- have sq : CommSq ρ P.p.1 Q.p.1 (𝟙 _) := by simp [h] + -- let cellLeft := (Over.starPullbackIsoStar ρ).hom + -- let cellMid := (pushforwardPullbackTwoSquare ρ P.p Q.p (𝟙 _) sq) + -- let cellLeftMidPasted := TwoSquare.whiskerRight (cellLeft ≫ₕ cellMid) (Over.pullbackId).inv + -- simpa using (cellLeftMidPasted ≫ₕ (vId (forget B))) + +/-- A cartesian map of polynomials +``` + P.p + E --------> B + | | + φ | | δ + v v + F --------> D + Q.p +``` +induces a natural transformation between their associated functors obtained by pasting the following +2-cells +``` + Q.p +C --- > C/F ----> C/D -----> C +| | | | +| ↗ | φ* ≅ | δ* ↗ | +| v v | +C --- > C/E ----> C/B ----> C + P.p +``` +-/ +def cartesianNatTrans {D F : C} (P : UvPoly R E B) (Q : UvPoly R F D) + (δ : B ⟶ D) (φ : E ⟶ F) (pb : IsPullback P.p φ δ Q.p) : P.functor ⟶ Q.functor := + sorry + -- let cellLeft : TwoSquare (𝟭 C) (Over.star F) (Over.star E) (pullback φ) := + -- (Over.starPullbackIsoStar φ).inv + -- let cellMid : TwoSquare (pullback φ) (pushforward Q.p) (pushforward P.p) (pullback δ) := + -- (pushforwardPullbackIsoSquare pb.flip).inv + -- let cellRight : TwoSquare (pullback δ) (forget D) (forget B) (𝟭 C) := + -- pullbackForgetTwoSquare δ + -- let := cellLeft ≫ᵥ cellMid ≫ᵥ cellRight + -- this + +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 + sorry + -- simp [cartesianNatTrans] + -- infer_instance + + -- (isCartesian_of_isIso _).vComp <| + -- (isCartesian_of_isIso _).vComp <| + -- isCartesian_pullbackForgetTwoSquare _ + +/-- 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⟩ + +-- def vertCartExchange + +/-- The composition of morphisms in the category of polynomials. -/ +def comp {E B F D N M : C} {P : UvPoly R E B} {Q : UvPoly R F D} {R : UvPoly R N M} + (f : Hom P Q) (g : Hom Q R) : Hom P R := sorry + +end Hom + +/-- The domain of the composition of two polynomials. See `UvPoly.comp`. -/ +def compDom {E B E' B' : C} (P : UvPoly R E B) (P' : UvPoly R E' B') : C := + sorry + -- Limits.pullback P'.p (fan P A).snd + +@[simps!] +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 := sorry -- pullback.snd Q.p (fan P A).snd ≫ pullback.fst (fan P A).fst P.p + morphismProperty := sorry + + +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 fstAux (pair : Γ ⟶ P @ X) : Over.mk (terminal.from Γ) ⟶ + ((toOverTerminal ⋙ MvPoly.functor P.mvPoly).obj X).toComma := Over.homMk pair + +def fst (pair : Γ ⟶ P @ X) : Γ ⟶ B := + (MvPoly.Equiv.fst (fstAux 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 (fstAux 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 (fstAux pair)) + +def snd' (pair : Γ ⟶ P @ X) {R f g} (H : IsPullback (P := R) f g (fst pair) P.p) : R ⟶ X := + H.isoPullback.hom ≫ snd pair + +theorem snd_eq_snd' (pair : Γ ⟶ P @ X) : + snd pair = snd' pair (.of_hasPullback ..) := by simp [snd']; sorry + -- simp lemma in HoTTLean ForMathlib + +/-- 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.mk (terminal.from (pullback b P.p.1)) ⟶ ((toOverTerminal (R := R)).obj X).toComma := + Over.homMk x + +def mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : Γ ⟶ P @ X := + (MvPoly.Equiv.mk (P := P.mvPoly) (Γ := Over.mk (terminal.from Γ)) + (Over.mk b) (by congr; apply terminal.hom_ext) (mkAux b x)).left + +def mk' (b : Γ ⟶ B) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ 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']; sorry + +@[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) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ X) : + fst (mk' b H x) = b := by + simp [mk'] + +@[simp] +lemma mk'_comp_fstProj (b : Γ ⟶ B) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ 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) {R f g} (H : IsPullback (P := R) 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 `R` used in `UvPoly.Equiv.snd'` with a different pullback `R'`. -/ +lemma snd'_eq_snd' (pair : Γ ⟶ P @ X) {R f g} (H : IsPullback (P := R) f g (fst pair) P.p) + {R' f' g'} (H' : IsPullback (P := R') 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) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ X) : + snd' (mk' b H x) (by rwa [fst_mk']) = x := by + sorry + -- have : comparison (c := fan P X) (mk' P X b H x) ≫ _ = + -- (pullback.congrHom (f₁ := mk' P X b H x ≫ _) ..).hom ≫ _ := + -- partialProd.lift_snd ⟨fan P X, isLimitFan P X⟩ b (H.isoPullback.inv ≫ x) + -- have H' : IsPullback (P := R) f g (mk' P X b H x ≫ (fan P X).fst) P.p.1 := by simpa + -- convert congr(H'.isoPullback.hom ≫ $(this)) using 1 + -- · simp [partialProd.snd, partialProd.cone, snd'_eq] + -- simp only [← Category.assoc]; congr! 2 + -- simp [comparison]; ext <;> simp + -- · slice_rhs 1 0 => skip + -- refine .symm <| .trans ?_ (Category.id_comp _); congr! 1 + -- rw [Iso.comp_inv_eq_id]; ext <;> simp + +lemma snd_mk_heq (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : + snd (mk b x) ≍ x := by + sorry + -- have h := mk_eq_mk' P X b x + -- set t := mk' P .. + -- have : snd' P X t _ = x := snd'_mk' .. + -- refine .trans ?_ this.heq + -- rw [snd_eq_snd']; congr! 2 <;> simp + +lemma snd_mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : + snd (mk b x) = eqToHom (by simp) ≫ x := by + apply eq_of_heq; rw [heq_eqToHom_comp_iff]; apply snd_mk_heq + +theorem snd'_comp_left (pair : Γ ⟶ P @ X) + {R f g} (H : IsPullback (P := R) f g (fst pair) P.p) + {Δ} (σ : Δ ⟶ Γ) + {R' f' g'} (H' : IsPullback (P := R') 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) + {R f1 f2} (H : IsPullback (P := R) f1 f2 (fst pair) P.p) : + snd' (pair ≫ P.functor.map f) (by rwa [fst_comp_right]) = + snd' pair H ≫ f := by + sorry + -- simp [snd'_eq, fan_snd, ε] + -- have := congr($((ExponentiableMorphism.ev P.p.1).naturality ((Over.star E).map f)).left ≫ prod.snd) + -- dsimp at this; simp at this + -- rw [← this]; clear this + -- simp only [← Category.assoc]; congr! 2 + -- ext <;> simp + -- · slice_rhs 2 3 => apply pullback.lift_fst + -- slice_rhs 1 2 => apply pullback.lift_fst + -- simp; rfl + -- · slice_rhs 2 3 => apply pullback.lift_snd + -- symm; apply pullback.lift_snd + +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 + -- rw [snd_eq_snd', snd'_comp_right, snd', Category.assoc, ← eqToIso.hom]; congr! 2 + -- exact IsPullback.isoPullback_eq_eqToIso_left (fst_comp_right _ _ _ f pair) P.p.1 + sorry + +lemma ext' {pair₁ pair₂ : Γ ⟶ P @ X} + {R f g} (H : IsPullback (P := R) 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 + -- simp [fst_eq] at h1 H + -- apply partialProd.hom_ext ⟨fan P X, isLimitFan P X⟩ h1 + -- refine (cancel_epi H.isoPullback.hom).1 ?_ + -- convert h2 using 1 <;> ( + -- simp [snd'_eq, comparison_pullback.map, partialProd.snd, partialProd.cone] + -- simp only [← Category.assoc]; congr! 2 + -- ext <;> simp) + -- · slice_lhs 2 3 => apply pullback.lift_fst + -- slice_lhs 1 2 => apply H.isoPullback_hom_fst + -- simp + -- · slice_lhs 2 3 => apply pullback.lift_snd + -- slice_lhs 1 2 => apply H.isoPullback_hom_snd + -- simp + sorry + +/-- Switch the selected pullback `R` used in `UvPoly.Equiv.mk'` with a different pullback `R'`. -/ +theorem mk'_eq_mk' (b : Γ ⟶ B) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ X) + {R' f' g'} (H' : IsPullback (P := R') f' g' b P.p) : + mk' b H x = mk' b H' ((IsPullback.isoIsPullback _ _ H H').inv ≫ x) := by + -- apply ext' P X (R := R) (f := f) (g := g) (by convert H; simp) + -- · rw [snd'_eq_snd' P X (mk' P X b H' ((IsPullback.isoIsPullback _ _ H H').inv ≫ x)) + -- (by convert H; simp) (by convert H'; simp)] + -- simp [snd'_mk'] + -- · simp + sorry + +@[simp] +lemma eta' (pair : Γ ⟶ P @ X) + {R f1 f2} (H : IsPullback (P := R) f1 f2 (fst pair) P.p) : + mk' (fst pair) H (snd' pair H) = pair := + .symm <| ext' H (by simp) (by simp) + +@[simp] +lemma eta (pair : Γ ⟶ P @ X) : + mk (fst pair) (snd pair) = pair := by + simp [mk_eq_mk', snd_eq_snd'] + +lemma mk'_comp_right (b : Γ ⟶ B) {R f1 f2} (H : IsPullback (P := R) f1 f2 b P.p) (x : R ⟶ 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 + sorry + +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) (R f g) (H : IsPullback (P := R) f g y P.p.1) +-- (x : R ⟶ X) (e : E ⟶ E') (b : B ⟶ B') +-- (hp : IsPullback P.p.1 e b P'.p.1) : +-- Equiv.mk' y H x ≫ (P.cartesianNatTrans P' b e hp).app X = +-- Equiv.mk' P' X (y ≫ b) (H.paste_vert hp) x := by +-- have : fst P' X (Equiv.mk' P X y H x ≫ (P.cartesianNatTrans P' b e hp).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 diff --git a/HoTTLean/ForPoly.lean b/HoTTLean/ForPoly.lean index b9a44a91..ef48535b 100644 --- a/HoTTLean/ForPoly.lean +++ b/HoTTLean/ForPoly.lean @@ -1,3 +1,4 @@ +#exit import Poly.UvPoly.Basic import HoTTLean.ForMathlib diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index 1586d26a..6e176179 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -1,12 +1,13 @@ import Mathlib.CategoryTheory.Limits.Shapes.KernelPair -import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.Presheaf -import Poly.UvPoly.UPFan +-- import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.Presheaf +-- import Poly.UvPoly.UPFan import HoTTLean.ForPoly import HoTTLean.ForMathlib.Tactic.CategoryTheory.FunctorMap import HoTTLean.ForMathlib.CategoryTheory.Yoneda import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone import HoTTLean.ForMathlib.CategoryTheory.WeakPullback +import HoTTLean.ForMathlib.CategoryTheory.Polynomial universe v u @@ -19,37 +20,44 @@ namespace NaturalModel /-- 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 Universe (Ctx : Type u) [Category Ctx] where - Tm : Psh Ctx - Ty : Psh Ctx +structure Universe {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) where + Tm : Ctx + Ty : Ctx tp : Tm ⟶ Ty - ext {Γ : Ctx} (A : y(Γ) ⟶ Ty) : Ctx - disp {Γ : Ctx} (A : y(Γ) ⟶ Ty) : ext A ⟶ Γ - var {Γ : Ctx} (A : y(Γ) ⟶ Ty) : y(ext A) ⟶ Tm - disp_pullback {Γ : Ctx} (A : y(Γ) ⟶ Ty) : - IsPullback (var A) ym(disp A) tp A + morphismProperty : R tp + 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 Universe -variable {Ctx : Type u} [SmallCategory Ctx] (M : Universe Ctx) +variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} (M : Universe R) + [R.HasPullbacks] [R.IsStableUnderBaseChange] + +instance {Γ : Ctx} (A : Γ ⟶ M.Ty) : HasPullback A M.tp := by + let tp : M.Tm ⟶(R) M.Ty := ⟨ M.tp, M.morphismProperty ⟩ + convert_to HasPullback A tp.1 + apply MorphismProperty.instHasPullbackFstHomOfHasPullbacks @[simps! hom inv] -def pullbackIsoExt {Γ : Ctx} (A : y(Γ) ⟶ M.Ty) : - pullback A M.tp ≅ yoneda.obj (M.ext A) := - -- The use of `IsPullback.flip` suggests an inconsistency in convention. +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 : y(Γ) ⟶ M.Ty) : Universe Ctx where - Tm := y(M.ext A) - Ty := y(Γ) - tp := ym(M.disp A) +protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : Universe R where + Tm := M.ext A + Ty := Γ + tp := M.disp A + morphismProperty := R.of_isPullback (disp_pullback ..) M.morphismProperty 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)) (ym(M.disp (B ≫ A)) ≫ B) (M.disp_pullback (B ≫ A)).w + 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) @@ -69,23 +77,19 @@ protected def pullback {Γ : Ctx} (A : y(Γ) ⟶ M.Ty) : Universe Ctx where construct a natural model structure on `π : E ⟶ U`, by pullback pasting. -/ -def ofIsPullback {U E : Psh Ctx} {π : E ⟶ U} +def ofIsPullback {U E : Ctx} {π : E ⟶ U} {toTy : U ⟶ M.Ty} {toTm : E ⟶ M.Tm} (pb : IsPullback toTm π M.tp toTy) : - Universe Ctx where + Universe R where Ty := U Tm := E tp := π + morphismProperty := R.of_isPullback pb M.morphismProperty ext A := M.ext (A ≫ toTy) disp A := M.disp (A ≫ toTy) - var A := pb.lift - (M.var (A ≫ toTy)) - (ym(M.disp (A ≫ toTy)) ≫ A) - (M.disp_pullback (A ≫ toTy)).w - disp_pullback A := - IsPullback.of_right' - (M.disp_pullback (A ≫ toTy)) - pb + 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 -/ @@ -105,29 +109,28 @@ def ofIsPullback {U E : Psh Ctx} {π : E ⟶ U} | V V ---> Γ ------ A -----> M.Ty -/ -def substCons {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : y(Γ) ⟶ M.Ty) - (t : y(Δ) ⟶ M.Tm) (t_tp : t ≫ M.tp = ym(σ) ≫ A) : +def substCons {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) + (t : Δ ⟶ M.Tm) (t_tp : t ≫ M.tp = σ ≫ A) : Δ ⟶ M.ext A := - Yoneda.fullyFaithful.1 <| (M.disp_pullback A).lift t ym(σ) t_tp + (M.disp_pullback A).lift t σ t_tp -@[functor_map (attr := reassoc (attr := simp))] -theorem substCons_disp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : y(Γ) ⟶ M.Ty) (t : y(Δ) ⟶ M.Tm) - (tTp : t ≫ M.tp = ym(σ) ≫ A) : +@[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 apply Yoneda.fullyFaithful.map_injective simp [substCons] @[reassoc (attr := simp)] -theorem substCons_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : y(Γ) ⟶ M.Ty) (t : y(Δ) ⟶ M.Tm) - (aTp : t ≫ M.tp = ym(σ) ≫ A) : - ym(M.substCons σ A t aTp) ≫ M.var A = t := by +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 : y(Γ) ⟶ M.Ty) (t : y(Δ) ⟶ M.Tm) - (aTp : t ≫ M.tp = ym(σ) ≫ A) : - τ ≫ M.substCons σ A t aTp = M.substCons (τ ≫ σ) A (ym(τ) ≫ t) (by simp [*]) := by - apply Yoneda.fullyFaithful.map_injective +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 @@ -139,7 +142,7 @@ theorem comp_substCons {Θ Δ Γ : Ctx} (τ : Θ ⟶ Δ) (σ : Δ ⟶ Γ) (A : y Δ ⊢ ↑∘σ : Γ ``` -/ -def substFst {Δ Γ : Ctx} {A : y(Γ) ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ Γ := +def substFst {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ Γ := σ ≫ M.disp A /-- @@ -149,15 +152,15 @@ def substFst {Δ Γ : Ctx} {A : y(Γ) ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ Δ ⊢ v₀[σ] : A[↑∘σ] ``` -/ -def substSnd {Δ Γ : Ctx} {A : y(Γ) ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : y(Δ) ⟶ M.Tm := - ym(σ) ≫ M.var A +def substSnd {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ M.Tm := + σ ≫ M.var A -theorem substSnd_tp {Δ Γ : Ctx} {A : y(Γ) ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : - M.substSnd σ ≫ M.tp = ym(M.substFst σ) ≫ A := by +theorem substSnd_tp {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : + M.substSnd σ ≫ M.tp = (M.substFst σ) ≫ A := by simp [substSnd, substFst]; rw [(M.disp_pullback _).w] @[reassoc (attr := simp)] -theorem var_tp {Γ : Ctx} (A : y(Γ) ⟶ M.Ty) : M.var A ≫ M.tp = ym(M.disp A) ≫ A := by +theorem var_tp {Γ : Ctx} (A : Γ ⟶ M.Ty) : M.var A ≫ M.tp = (M.disp A) ≫ A := by simp [(M.disp_pullback A).w] /-- @@ -170,18 +173,18 @@ Weaken a substitution. Δ.A' ⊢ (↑≫σ).v₀ : Γ.A ``` -/ -def substWk {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : y(Γ) ⟶ M.Ty) - (A' := ym(σ) ≫ A) (eq : ym(σ) ≫ A = A' := by rfl) : M.ext A' ⟶ M.ext 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]) -@[functor_map (attr := reassoc)] -theorem substWk_disp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : y(Γ) ⟶ M.Ty) (A' 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 : y(Γ) ⟶ M.Ty) (A' eq) : - ym(M.substWk σ A A' eq) ≫ M.var A = M.var A' := by +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`. @@ -195,126 +198,126 @@ theorem substWk_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : y(Γ) ⟶ M.Ty) (A' eq) ‖ | | ‖ V V ===== Γ ------ A -----> M.Ty -/ -def sec {Γ : Ctx} (A : y(Γ) ⟶ M.Ty) (a : y(Γ) ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : Γ ⟶ M.ext A := +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]) -@[functor_map (attr := reassoc (attr := simp))] -theorem sec_disp {Γ : Ctx} (A : y(Γ) ⟶ M.Ty) (a : y(Γ) ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : +@[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 : y(Γ) ⟶ M.Ty) (a : y(Γ) ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : - ym(M.sec A a a_tp) ≫ M.var A = a := by +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] -@[functor_map (attr := reassoc)] -theorem comp_sec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : y(Γ) ⟶ M.Ty) (σA) (eq : ym(σ) ≫ A = σA) - (a : y(Γ) ⟶ M.Tm) (a_tp : a ≫ M.tp = A) : - σ ≫ M.sec A a a_tp = M.sec σA (ym(σ) ≫ a) (by simp [eq, a_tp]) ≫ M.substWk σ A _ eq := by - apply Yoneda.fullyFaithful.map_injective +@[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_disp_functor_map] + simp [sec, substWk] /-! ## Polynomial functor on `tp` Specializations of results from the `Poly` package to natural models. -/ -@[simps] def uvPolyTp : UvPoly M.Tm M.Ty := ⟨M.tp, inferInstance⟩ -def Ptp : Psh Ctx ⥤ Psh Ctx := M.uvPolyTp.functor +abbrev uvPolyTp : UvPoly R M.Tm M.Ty := ⟨M.tp, M.morphismProperty⟩ + +variable [HasTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] + [R.HasPushforwards R] [R.IsStableUnderPushforward R] + +def Ptp : Ctx ⥤ Ctx := M.uvPolyTp.functor namespace PtpEquiv -variable {Γ : Ctx} {X : Psh Ctx} +variable {Γ : Ctx} {X : Ctx} --- TODO: possibly want to remove M.uvPolyTp.equiv --- and directly define `fst`, `snd`, etc. /-- -A map `(AB : y(Γ) ⟶ M.Ptp.obj X)` is equivalent to a pair of maps -`A : y(Γ) ⟶ M.Ty` and `B : y(M.ext (fst M AB)) ⟶ X`, +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 : y(Γ) ⟶ M.Ptp.obj X) : y(Γ) ⟶ M.Ty := - UvPoly.Equiv.fst M.uvPolyTp X AB +def fst (AB : Γ ⟶ M.Ptp.obj X) : Γ ⟶ M.Ty := + UvPoly.Equiv.fst AB /-- -A map `(AB : y(Γ) ⟶ M.Ptp.obj X)` is equivalent to a pair of maps -`A : y(Γ) ⟶ M.Ty` and `B : y(M.ext (fst M AB)) ⟶ X`, +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 : y(Γ) ⟶ M.Ptp.obj X) (A := fst M AB) (eq : fst M AB = A := by rfl) : y(M.ext A) ⟶ X := - UvPoly.Equiv.snd' M.uvPolyTp X AB (by rw [← fst, eq]; exact (M.disp_pullback _).flip) +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 : y(Γ) ⟶ M.Ptp.obj X)` is equivalent to a pair of maps -`A : y(Γ) ⟶ M.Ty` and `B : y(M.ext (fst M AB)) ⟶ X`, +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 : y(Γ) ⟶ M.Ty) (B : y(M.ext A) ⟶ X) : y(Γ) ⟶ M.Ptp.obj X := - UvPoly.Equiv.mk' M.uvPolyTp X A (M.disp_pullback _).flip 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 : y(Γ) ⟶ M.Ty) (B : y(M.ext A) ⟶ X) : +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 : y(Γ) ⟶ M.Ty) (B : y(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'] section -variable {Δ : Ctx} {σ : Δ ⟶ Γ} {AB : y(Γ) ⟶ M.Ptp.obj X} +variable {Δ : Ctx} {σ : Δ ⟶ Γ} {AB : Γ ⟶ M.Ptp.obj X} -theorem fst_comp_left (σ : y(Δ) ⟶ y(Γ)) : fst M (σ ≫ AB) = σ ≫ fst M AB := +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 σ) _ (fst_comp_right M σ ▸ eq) = snd M AB _ eq ≫ σ := by + snd M (AB ≫ M.Ptp.map σ) _ (by simpa) = snd M AB _ eq ≫ σ := by simp only [snd, Ptp] - rw [UvPoly.Equiv.snd'_comp_right M.uvPolyTp X Y σ AB] + rw [UvPoly.Equiv.snd'_comp_right] -theorem snd_comp_left {A} (eqA : fst M AB = A) {σA} (eqσ : ym(σ) ≫ A = σA) : - snd M (ym(σ) ≫ AB) σA (by simp [fst_comp_left, eqA, eqσ]) = - ym(M.substWk σ _ _ eqσ) ≫ snd M AB _ eqA := by - have H1 : IsPullback ym(M.disp A) (M.var A) (UvPoly.Equiv.fst M.uvPolyTp X AB) M.uvPolyTp.p := by +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 ym(M.disp σA) (M.var σA) - (ym(σ) ≫ UvPoly.Equiv.fst M.uvPolyTp X AB) M.uvPolyTp.p := by + 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 M.uvPolyTp X AB H1 _ H2 - apply H1.hom_ext <;> simp [← Functor.map_comp, substWk] + convert UvPoly.Equiv.snd'_comp_left AB H1 _ H2 + apply H1.hom_ext <;> simp [substWk] -theorem mk_comp_left {Δ Γ : Ctx} (M : Universe Ctx) (σ : Δ ⟶ Γ) - {X : Psh Ctx} (A : y(Γ) ⟶ M.Ty) (σA) (eq : ym(σ) ≫ A = σA) (B : y(M.ext A) ⟶ X) : - ym(σ) ≫ PtpEquiv.mk M A B = PtpEquiv.mk M σA (ym(M.substWk σ A _ eq) ≫ B) := by +theorem mk_comp_left {Δ Γ : Ctx} (M : Universe 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 M.uvPolyTp X A (M.disp_pullback A).flip B ym(σ) - σA eq (M.disp_pullback σA).flip + 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 [← Functor.map_comp, substWk_disp] + · simp [substWk_disp] -theorem mk_comp_right {Γ : Ctx} (M : Universe Ctx) - {X Y : Psh Ctx} (σ : X ⟶ Y) (A : y(Γ) ⟶ M.Ty) (B : y(M.ext A) ⟶ X) : +theorem mk_comp_right {Γ : Ctx} (M : Universe 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 M.uvPolyTp X Y σ A (M.disp_pullback A).flip B + UvPoly.Equiv.mk'_comp_right .. -theorem ext {AB AB' : y(Γ) ⟶ 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 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 : y(Γ) ⟶ M.Ptp.obj X) : mk M (fst M AB) (snd M AB) = AB := +theorem eta (AB : Γ ⟶ M.Ptp.obj X) : mk M (fst M AB) (snd M AB) = AB := .symm <| ext _ _ rfl (by simp) (by simp) end @@ -322,8 +325,8 @@ end end PtpEquiv @[reassoc] -theorem PtpEquiv.mk_map {Γ : Ctx} {X Y : Psh Ctx} - (A : y(Γ) ⟶ M.Ty) (x : y(M.ext A) ⟶ X) (α : X ⟶ Y) : +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] @@ -331,27 +334,27 @@ theorem PtpEquiv.mk_map {Γ : Ctx} {X Y : Psh Ctx} -- -- `private` lemma for the equivalence below. -- private lemma lift_ev {Γ : Ctx} {N : Universe Ctx} --- {AB : y(Γ) ⟶ M.Ptp.obj N.Ty} {α : y(Γ) ⟶ M.Tm} +-- {AB : Γ ⟶ M.Ptp.obj N.Ty} {α : Γ ⟶ M.Tm} -- (hA : AB ≫ M.uvPolyTp.fstProj N.Ty = α ≫ M.tp) : -- pullback.lift AB α hA ≫ (UvPoly.PartialProduct.fan M.uvPolyTp N.Ty).snd = --- ym(M.sec (α ≫ M.tp) α rfl) ≫ --- (M.disp_pullback _).lift (M.var _) ym(M.disp _) +-- (M.sec (α ≫ M.tp) α rfl) ≫ +-- (M.disp_pullback _).lift (M.var _) (M.disp _) -- (by dsimp; rw [hA, (M.disp_pullback _).w]) ≫ -- (M.Ptp_equiv AB).2 := -- sorry +/- namespace compDomEquiv open UvPoly -variable {M N : Universe Ctx} {Γ Δ : Ctx} (σ : Δ ⟶ Γ) - +variable {M N : Universe R} {Γ Δ : Ctx} (σ : Δ ⟶ Γ) /-- Universal property of `compDom`, decomposition (part 1). -A map `ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps -`fst, dependent, snd` such that `fst_tp` and `snd_tp`. The map `fst : y(Γ) ⟶ M.Tm` +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)`. -/ -def fst (ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) : y(Γ) ⟶ M.Tm := +def fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ M.Tm := ab ≫ pullback.snd N.tp (UvPoly.PartialProduct.fan M.uvPolyTp N.Ty).snd ≫ pullback.snd (M.uvPolyTp.fstProj N.Ty) M.uvPolyTp.p @@ -367,7 +370,7 @@ def fst (ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) : y(Γ) ⟶ M.Tm := > P_tp Ty Namely the first projection `α ≫ tp` agrees. -/ -theorem fst_tp (ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) : +theorem fst_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : fst ab ≫ M.tp = PtpEquiv.fst M (ab ≫ (M.uvPolyTp.compP _)) := by have : pullback.snd (M.uvPolyTp.fstProj N.Ty) M.tp ≫ M.tp = pullback.fst (M.uvPolyTp.fstProj N.Ty) M.tp ≫ M.uvPolyTp.fstProj N.Ty := @@ -375,59 +378,59 @@ theorem fst_tp (ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) : simp [PtpEquiv.fst, fst, this] rfl -theorem comp_fst (ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : y(Δ) ⟶ y(Γ)) : +theorem comp_fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : σ ≫ fst ab = fst (σ ≫ ab) := by simp [fst] /-- Universal property of `compDom`, decomposition (part 2). -A map `ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +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 : y(M.ext (fst N ab ≫ M.tp)) ⟶ M.Ty` +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 : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) +def dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (A := fst ab ≫ M.tp) (eq : fst ab ≫ M.tp = A := by rfl) : - y(M.ext A) ⟶ N.Ty := + (M.ext A) ⟶ N.Ty := PtpEquiv.snd M (ab ≫ (M.uvPolyTp.compP _)) _ (by rw [← eq, fst_tp]) -theorem comp_dependent (ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) +theorem comp_dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) {A} (eq1 : fst ab ≫ M.tp = A) - {σA} (eq2 : ym(σ) ≫ A = σA) : - ym(substWk M σ _ _ eq2) ≫ dependent ab A eq1 = - dependent (ym(σ) ≫ ab) σA (by simp [← comp_fst, eq1, eq2]) := by + {σA} (eq2 : σ ≫ A = σA) : + (substWk M σ _ _ eq2) ≫ dependent ab A eq1 = + dependent (σ ≫ ab) σA (by simp [← comp_fst, eq1, eq2]) := by rw [dependent, ← PtpEquiv.snd_comp_left]; rfl /-- Universal property of `compDom`, decomposition (part 3). -A map `ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +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 : y(Γ) ⟶ M.Tm` +The map `snd : Γ ⟶ M.Tm` is the `(b : B a)` in `(a : A) × (b : B a)`. -/ -def snd (ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) : y(Γ) ⟶ N.Tm := +def snd (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ N.Tm := ab ≫ pullback.fst N.tp (PartialProduct.fan M.uvPolyTp N.Ty).snd -theorem comp_snd (ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : y(Δ) ⟶ y(Γ)) : +theorem comp_snd (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : σ ≫ snd ab = snd (σ ≫ ab) := by simp [snd] /-- Universal property of `compDom`, decomposition (part 4). -A map `ab : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps +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 : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp) +theorem snd_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) {A} (eq : fst ab ≫ M.tp = A) : - snd ab ≫ N.tp = ym(M.sec _ (fst ab) eq) ≫ dependent ab A eq := by + snd ab ≫ N.tp = (M.sec _ (fst ab) eq) ≫ dependent ab A eq := by simp [snd, pullback.condition, dependent, PtpEquiv.snd, Equiv.snd'_eq] simp only [← Category.assoc]; congr! 1 apply pullback.hom_ext <;> simp [fst, UvPoly.compP] /-- Universal property of `compDom`, constructing a map into `compDom`. -/ -def mk (α : y(Γ) ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : y(M.ext A) ⟶ N.Ty) (β : y(Γ) ⟶ N.Tm) - (h : β ≫ N.tp = ym(M.sec _ α eq) ≫ B) : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp := by +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 := by refine pullback.lift β (pullback.lift (PtpEquiv.mk _ A B) α ?_) ?_ · simp [← Equiv.fst_eq, ← PtpEquiv.fst.eq_def, eq] · simp [h] @@ -438,14 +441,14 @@ def mk (α : y(Γ) ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : y(M.ext A) ⟶ N.Ty apply pullback.hom_ext <;> simp @[simp] -theorem fst_mk (α : y(Γ) ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : y(M.ext A) ⟶ N.Ty) (β : y(Γ) ⟶ N.Tm) - (h : β ≫ N.tp = ym(M.sec _ α eq) ≫ B) : fst (mk α eq B β h) = α := by +theorem fst_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (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 (α : y(Γ) ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) - (B : y(M.ext A) ⟶ N.Ty) (β : y(Γ) ⟶ N.Tm) - (h : β ≫ N.tp = ym(M.sec _ α eq) ≫ B) : +theorem dependent_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) + (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) + (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : dependent (mk α eq B β h) A (by simp [fst_mk, eq]) = B := by simp [mk, dependent, UvPoly.compP] convert PtpEquiv.snd_mk M A B using 2 @@ -453,11 +456,11 @@ theorem dependent_mk (α : y(Γ) ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) simp @[simp] -theorem snd_mk (α : y(Γ) ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : y(M.ext A) ⟶ N.Ty) (β : y(Γ) ⟶ N.Tm) - (h : β ≫ N.tp = ym(M.sec _ α eq) ≫ B) : snd (mk α eq B β h) = β := by +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₂ : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp} +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)) @@ -470,25 +473,25 @@ theorem ext {ab₁ ab₂ : y(Γ) ⟶ M.uvPolyTp.compDom N.uvPolyTp} simp only [← Category.assoc]; congr 1 theorem comp_mk - (α : y(Γ) ⟶ M.Tm) {A} (e1 : α ≫ M.tp = A) - (B : y(M.ext A) ⟶ N.Ty) - (β : y(Γ) ⟶ N.Tm) - (e2 : β ≫ N.tp = ym(M.sec A α e1) ≫ B) - (σ : Δ ⟶ Γ) {σA} (e3 : ym(σ) ≫ A = σA) : - ym(σ) ≫ mk α e1 B β e2 = - mk (ym(σ) ≫ α) (by simp [e1, e3]) - (ym(M.substWk σ A _ e3) ≫ B) (ym(σ) ≫ β) + (α : Γ ⟶ 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 [← Functor.map_comp_assoc, comp_sec]; simp; congr!) := by apply ext (A := σA) (by simp [← comp_fst, e1, e3]) <;> simp [← comp_fst, ← comp_snd] rw [← comp_dependent, dependent_mk] -theorem eta (ab : y(Γ) ⟶ M.uvPolyTp.compDom 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 and Sigma types -/ set_option linter.dupNamespace false in @@ -500,7 +503,7 @@ protected structure Pi where protected structure Sigma where Sig : M.Ptp.obj M.Ty ⟶ M.Ty pair : UvPoly.compDom (uvPolyTp M) (uvPolyTp M) ⟶ M.Tm - Sig_pullback : IsPullback pair ((uvPolyTp M).compP (uvPolyTp M)) M.tp Sig + -- Sig_pullback : IsPullback pair ((uvPolyTp M).compP (uvPolyTp M)) M.tp Sig /-- Universe.IdIntro consists of the following commutative square @@ -533,7 +536,7 @@ when constructing a model it is convenient to know that `k` is some specific construction on-the-nose. -/ structure IdIntro where - k : Psh Ctx + k : Ctx k1 : k ⟶ M.Tm k2 : k ⟶ M.Tm isKernelPair : IsKernelPair M.tp k1 k2 @@ -546,29 +549,32 @@ 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 : y(Γ) ⟶ M.Tm) +def mkId (a0 a1 : Γ ⟶ M.Tm) (a0_tp_eq_a1_tp : a0 ≫ M.tp = a1 ≫ M.tp) : - y(Γ) ⟶ M.Ty := + Γ ⟶ M.Ty := idIntro.isKernelPair.lift a1 a0 (by rw [a0_tp_eq_a1_tp]) ≫ idIntro.Id theorem comp_mkId {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (a0 a1 : y(Γ) ⟶ M.Tm) (eq : a0 ≫ M.tp = a1 ≫ M.tp) : - ym(σ) ≫ mkId idIntro a0 a1 eq = - mkId idIntro (ym(σ) ≫ a0) (ym(σ) ≫ a1) (by simp [eq]) := by + (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 : y(Γ) ⟶ M.Tm) : y(Γ) ⟶ M.Tm := +def mkRefl (a : Γ ⟶ M.Tm) : Γ ⟶ M.Tm := a ≫ idIntro.refl -theorem comp_mkRefl {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (a : y(Γ) ⟶ M.Tm) : - ym(σ) ≫ idIntro.mkRefl a = idIntro.mkRefl (ym(σ) ≫ a) := - rfl +theorem comp_mkRefl {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) : + σ ≫ idIntro.mkRefl a = idIntro.mkRefl (σ ≫ a) := by + simp [mkRefl] @[simp] -theorem mkRefl_tp (a : y(Γ) ⟶ M.Tm) : +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] @@ -581,46 +587,46 @@ theorem mkRefl_tp (a : y(Γ) ⟶ M.Tm) : Γ.(x:A).(h:Id(A,a,x)) ⊢ M ... -/ -def motiveCtx (a : y(Γ) ⟶ M.Tm) : Ctx := - M.ext (idIntro.mkId (ym(M.disp (a ≫ M.tp)) ≫ a) (M.var _) (by simp)) +def motiveCtx (a : Γ ⟶ M.Tm) : Ctx := + M.ext (idIntro.mkId ((M.disp (a ≫ M.tp)) ≫ a) (M.var _) (by simp)) -def motiveSubst {Γ Δ} (σ : Δ ⟶ Γ) (a : y(Γ) ⟶ M.Tm) : - motiveCtx idIntro (ym(σ) ≫ a) ⟶ motiveCtx idIntro a := by +def motiveSubst {Γ Δ} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) : + motiveCtx idIntro (σ ≫ a) ⟶ motiveCtx idIntro a := by refine substWk _ (substWk _ σ _ _ (by simp)) _ _ ?_ - simp [comp_mkId]; congr 1; simp only [← Functor.map_comp_assoc, substWk_disp] + simp [comp_mkId]; congr 1; simp only [← Category.assoc, substWk_disp] /-- The substitution `(a,refl)` appearing in identity elimination `J` - `(a,refl) : y(Γ) ⟶ y(Γ.(x:A).(h:Id(A,a,x)))` + `(a,refl) : Γ ⟶ (Γ.(x:A).(h:Id(A,a,x)))` so that we can write `Γ ⊢ r : M(a,refl)` -/ -def reflSubst (a : y(Γ) ⟶ M.Tm) : Γ ⟶ idIntro.motiveCtx a := +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 : y(Γ) ⟶ M.Tm) : - ym(σ) ≫ ym(idIntro.reflSubst a) = - ym(idIntro.reflSubst (ym(σ) ≫ a)) ≫ ym(idIntro.motiveSubst σ a) := by +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 : y(Γ) ⟶ M.Tm) {Δ} (σ : Δ ⟶ Γ) : - reflSubst idIntro (ym(σ) ≫ a) ≫ idIntro.motiveSubst σ a = σ ≫ reflSubst idIntro a := by +lemma comp_reflSubst (a : Γ ⟶ M.Tm) {Δ} (σ : Δ ⟶ Γ) : + reflSubst idIntro (σ ≫ a) ≫ idIntro.motiveSubst σ a = σ ≫ reflSubst idIntro a := by apply Yoneda.fullyFaithful.map_injective simp [Functor.map_comp, comp_reflSubst'] -def toK (ii : IdIntro M) (a : y(Γ) ⟶ M.Tm) : y(M.ext (a ≫ M.tp)) ⟶ ii.k := - ii.isKernelPair.lift (M.var _) (ym(M.disp _) ≫ a) (by simp) +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 : y(Γ) ⟶ M.Tm) : ii.toK a ≫ ii.k1 = M.var _ := by +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 : y(Γ) ⟶ M.Tm) : - IsPullback (ii.toK a) ym(M.disp _) ii.k2 a := +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 @@ -634,28 +640,28 @@ 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 : Universe Ctx) where - j {Γ} (a : y(Γ) ⟶ M.Tm) (C : y(IdIntro.motiveCtx _ a) ⟶ N.Ty) (r : y(Γ) ⟶ N.Tm) - (r_tp : r ≫ N.tp = ym(i.reflSubst a) ≫ C) : - y(i.motiveCtx a) ⟶ N.Tm - j_tp {Γ} (a : y(Γ) ⟶ M.Tm) (C : y(IdIntro.motiveCtx _ a) ⟶ N.Ty) (r : y(Γ) ⟶ N.Tm) - (r_tp : r ≫ N.tp = ym(i.reflSubst a) ≫ C) : j a C r r_tp ≫ N.tp = C +protected structure Id' (i : IdIntro M) (N : Universe 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 : y(Γ) ⟶ M.Tm) (C : y(IdIntro.motiveCtx _ a) ⟶ N.Ty) (r : y(Γ) ⟶ N.Tm) - (r_tp : r ≫ N.tp = ym(i.reflSubst a) ≫ C) : - ym(i.motiveSubst σ _) ≫ j a C r r_tp = - j (ym(σ) ≫ a) (ym(i.motiveSubst σ _) ≫ C) (ym(σ) ≫ r) (by + (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 : y(Γ) ⟶ M.Tm) (C : y(IdIntro.motiveCtx _ a) ⟶ N.Ty) (r : y(Γ) ⟶ N.Tm) - (r_tp : r ≫ N.tp = ym(i.reflSubst a) ≫ C) : - ym(i.reflSubst a) ≫ j a C r r_tp = r + 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 : Universe Ctx} {ii : M.IdIntro} (i : M.Id' ii N) {Γ : Ctx} (a : y(Γ) ⟶ M.Tm) - (C : y(ii.motiveCtx a) ⟶ N.Ty) (r : y(Γ) ⟶ N.Tm) - (r_tp : r ≫ N.tp = ym(ii.reflSubst a) ≫ C) (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 {M} {N : Universe 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 @@ -671,17 +677,17 @@ def endPtSubst : Γ ⟶ ii.motiveCtx a := `Γ ⊢ 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 : y(Γ) ⟶ N.Tm := - ym(endPtSubst a b b_tp h h_tp) ≫ i.j a C r r_tp +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 = ym(endPtSubst a b b_tp h h_tp) ≫ C := by +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 ym(endPtSubst a a _ (ii.mkRefl a) _) ≫ i.j a C r r_tp - _ = ym(ii.reflSubst a) ≫ i.j a C r r_tp := rfl + 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' @@ -706,7 +712,7 @@ this may not be definitionally equal to the pullbacks we construct, for example using context extension. -/ structure IdElimBase (ii : IdIntro M) where - i : Psh Ctx + i : Ctx i1 : i ⟶ M.Tm i2 : i ⟶ ii.k i_isPullback : IsPullback i1 i2 M.tp ii.Id @@ -714,6 +720,9 @@ structure IdElimBase (ii : IdIntro M) where 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 @@ -751,12 +760,13 @@ lemma comparison_comp_i2_comp_k2 : ie.comparison ≫ ie.i2 ≫ ii.k2 = `(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 `Psh Ctx`. +This is the signature for a polynomial functor `iUvPoly` on the presheaf category `Ctx`. -/ -@[simps] def iUvPoly : UvPoly ie.i M.Tm := ⟨ie.i2 ≫ ii.k2, inferInstance⟩ +abbrev iUvPoly : UvPoly R ie.i M.Tm := + ie.i2UvPoly.vcomp ii.k2UvPoly /-- The functor part of the polynomial endofunctor `iOverUvPoly` -/ -abbrev iFunctor : Psh Ctx ⥤ Psh Ctx := ie.iUvPoly.functor +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 @@ -770,562 +780,20 @@ Tm ----> i VV Tm -/ -def verticalNatTrans : ie.iFunctor ⟶ (UvPoly.id M.Tm).functor := +def verticalNatTrans : ie.iFunctor ⟶ (UvPoly.id R M.Tm).functor := UvPoly.verticalNatTrans (UvPoly.id M.Tm) ie.iUvPoly ie.comparison (by simp [iUvPoly]) section reflCase -variable (i : IdIntro M) {N : Universe Ctx} - -variable {Γ : Ctx} (a : y(Γ) ⟶ M.Tm) (r : y(Γ) ⟶ N.Tm) - -lemma reflCase_aux : IsPullback (𝟙 y(Γ)) a a (UvPoly.id M.Tm).p := - have : IsIso (UvPoly.id 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 : y(Γ) ⟶ (UvPoly.id M.Tm).functor.obj N.Tm := - UvPoly.Equiv.mk' (UvPoly.id M.Tm) N.Tm a (R := y(Γ)) (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 : Psh Ctx} - -section -variable (a : y(Γ) ⟶ 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 - | - y(Γ.a≫tp.Id(...)) ------> i ------> Tm - | | | - | | i₂ V - | | Ty - V V - y(Γ.a≫tp) ------------> k ------> Tm - | | k₁ | - | |k₂ |tp - | | | - | V V - y(Γ) ----------------> Tm -----> Ty - a tp --/ - -lemma toK_comp_left {Δ} (σ : Δ ⟶ Γ) : ii.toK (ym(σ) ≫ a) = - ym(M.substWk σ (a ≫ M.tp)) ≫ ii.toK a := by - dsimp [toK] - apply ii.isKernelPair.hom_ext - -- FIXME: `transparency := .default` is like `erw` and should be avoided - · rw! (transparency := .default) [Category.assoc] - simp - · simp only [IsKernelPair.lift_snd, Category.assoc] - slice_rhs 1 2 => rw [← Functor.map_comp, substWk_disp] - -- FIXME: `transparency := .default` is like `erw` and should be avoided - rw! (transparency := .default) [Category.assoc] - simp - -def toI : y(ii.motiveCtx a) ⟶ ie.i := - ie.i_isPullback.lift (M.var _) (ym(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 = ym(M.disp _) ≫ ii.toK a := - by simp [toI] - -lemma toI_comp_left {Δ} (σ : Δ ⟶ Γ) : toI ie (ym(σ) ≫ a) = - ym(ii.motiveSubst σ a) ≫ toI ie a := by - dsimp [toI] - apply ie.i_isPullback.hom_ext - · simp [motiveSubst] - · simp [toK_comp_left, motiveSubst, substWk, substCons] - rfl - -theorem motiveCtx_isPullback : - IsPullback (ie.toI a) ym(M.disp _) ie.i2 (toK ii a) := - IsPullback.of_right' (M.disp_pullback _) ie.i_isPullback - -theorem motiveCtx_isPullback' : - IsPullback (ie.toI a) (ym(M.disp (ii.mkId (ym(M.disp (a ≫ M.tp)) ≫ a) - (M.var (a ≫ M.tp)) (by simp))) ≫ ym(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 : y(ii.motiveCtx a) ⟶ X) : y(Γ) ⟶ ie.iFunctor.obj X := - UvPoly.Equiv.mk' ie.iUvPoly X a (ie.motiveCtx_isPullback' a).flip x - -def equivFst (pair : y(Γ) ⟶ ie.iFunctor.obj X) : - y(Γ) ⟶ M.Tm := - UvPoly.Equiv.fst ie.iUvPoly X pair - -lemma equivFst_comp_left (pair : y(Γ) ⟶ ie.iFunctor.obj X) - {Δ} (σ : Δ ⟶ Γ) : - ie.equivFst (ym(σ) ≫ pair) = ym(σ) ≫ ie.equivFst pair := by - dsimp [equivFst] - rw [UvPoly.Equiv.fst_comp_left] - -def equivSnd (pair : y(Γ) ⟶ ie.iFunctor.obj X) : - y(ii.motiveCtx (equivFst ie pair)) ⟶ X := - UvPoly.Equiv.snd' ie.iUvPoly X pair (ie.motiveCtx_isPullback' _).flip - -lemma equivSnd_comp_left (pair : y(Γ) ⟶ ie.iFunctor.obj X) - {Δ} (σ : Δ ⟶ Γ) : - ie.equivSnd (ym(σ) ≫ pair) = - ym(ii.motiveSubst σ _) ≫ ie.equivSnd pair := by - dsimp only [equivSnd] - let a := ie.equivFst pair - have H : IsPullback (ie.toI a) - (ym(M.disp (ii.mkId (ym(M.disp (a ≫ M.tp)) ≫ a) (M.var (a ≫ M.tp)) _)) ≫ - ym(M.disp (a ≫ M.tp))) ie.iUvPoly.p - (UvPoly.Equiv.fst ie.iUvPoly X pair) := (motiveCtx_isPullback' _ _) - have H' : IsPullback (ym(M.disp - (ii.mkId (ym(M.disp (ie.equivFst (ym(σ) ≫ pair) ≫ M.tp)) ≫ - ie.equivFst (ym(σ) ≫ pair)) - (M.var (ie.equivFst (ym(σ) ≫ pair) ≫ M.tp)) _)) ≫ - ym(M.disp (ie.equivFst (ym(σ) ≫ pair) ≫ M.tp))) - (ie.toI (ie.equivFst (ym(σ) ≫ pair))) - (ym(σ) ≫ 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 (ym(σ) ≫ pair)) = - ym(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 : Psh Ctx} - (pair : y(Γ) ⟶ 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 : Psh Ctx} - (pair : y(Γ) ⟶ ie.iFunctor.obj X) : - UvPoly.Equiv.snd' (UvPoly.id M.Tm) X (pair ≫ ie.verticalNatTrans.app X) - (R := y(Γ)) (f := 𝟙 _) (g := ie.equivFst pair) (by - convert reflCase_aux (ie.equivFst pair) - rw [equivFst_verticalNatTrans_app]) = - ym(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 : Psh Ctx} (a : y(Γ) ⟶ M.Tm) - (x : y(ii.motiveCtx a) ⟶ X) : - ie.equivMk a x ≫ (ie.verticalNatTrans).app X = - UvPoly.Equiv.mk' (UvPoly.id M.Tm) X a (R := y(Γ)) (f := 𝟙 _) (g := a) - (reflCase_aux a) (ym(ii.reflSubst a) ≫ x) := by - dsimp only [equivMk, verticalNatTrans] - rw [UvPoly.mk'_comp_verticalNatTrans_app (R' := y(Γ)) (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 +variable (i : IdIntro M) {N : Universe R} -end Equiv +variable {Γ : Ctx} (a : Γ ⟶ M.Tm) (r : Γ ⟶ N.Tm) -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 : Universe Ctx) where - weakPullback : WeakPullback - (ie.verticalNatTrans.app N.Tm) - (ie.iFunctor.map N.tp) - ((UvPoly.id M.Tm).functor.map N.tp) - (ie.verticalNatTrans.app N.Ty) - -namespace Id - -variable {N : Universe Ctx} {ii : IdIntro M} {ie : IdElimBase ii} (i : Id ie N) - -variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) (a : y(Γ) ⟶ M.Tm) - (C : y(ii.motiveCtx a) ⟶ N.Ty) (r : y(Γ) ⟶ N.Tm) - (r_tp : r ≫ N.tp = ym(ii.reflSubst a) ≫ C) - -open IdElimBase IdIntro - -lemma reflCase_aux : IsPullback (𝟙 y(Γ)) a a (UvPoly.id M.Tm).p := +lemma reflCase_aux : IsPullback (𝟙 Γ) a a (UvPoly.id R M.Tm).p := have : IsIso (UvPoly.id 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 : y(Γ) ⟶ (UvPoly.id M.Tm).functor.obj N.Tm := - UvPoly.Equiv.mk' (UvPoly.id M.Tm) N.Tm a (R := y(Γ)) (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 -``` --/ -abbrev motive : y(Γ) ⟶ ie.iFunctor.obj N.Ty := - ie.equivMk a C - -lemma motive_comp_left : ym(σ) ≫ motive ie a C = - motive ie (ym(σ) ≫ a) (ym(motiveSubst ii σ a) ≫ C) := by - dsimp [motive, equivMk] - rw [UvPoly.Equiv.mk'_comp_left (iUvPoly ie) _ a - (ie.motiveCtx_isPullback' a).flip C ym(σ) _ 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 : y(Γ) ⟶ 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 (ym(σ) ≫ a) (ym(ii.motiveSubst σ a) ≫ C) - (ym(σ) ≫ r) (by simp [r_tp, comp_reflSubst'_assoc]) = - ym(σ) ≫ 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 ym(σ) _ rfl - (reflCase_aux (ym(σ) ≫ 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 --- TODO: prove the other half of the equivalence. --- Generalize this version so that the universe for elimination is not also `M` - -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 diff --git a/HoTTLean/Syntax/Substitution.lean b/HoTTLean/Syntax/Substitution.lean index faa21024..be35f270 100644 --- a/HoTTLean/Syntax/Substitution.lean +++ b/HoTTLean/Syntax/Substitution.lean @@ -370,7 +370,8 @@ theorem subst_all : ∀ {Δ σ σ'}, EqSb E Δ σ σ' Γ → E ∣ Δ ⊢[l] t.subst σ ≡ t.subst σ' : A.subst σ) ∧ (∀ {Γ l A t u}, E ∣ Γ ⊢[l] t ≡ u : A → ∀ {Δ σ σ'}, EqSb E Δ σ σ' Γ → E ∣ Δ ⊢[l] t.subst σ ≡ u.subst σ' : A.subst σ) := by - mutual_induction WfCtx + sorry +/- mutual_induction WfCtx all_goals dsimp; try intros all_goals try simp only [Expr.subst_toSb_subst, Expr.subst_snoc_toSb_subst, Expr.subst] at * case ax p _ Ec _ _ ihA => @@ -508,7 +509,7 @@ theorem subst_all : apply (EqTm.pair_fst_snd' ..).trans_tm' <;> grind [WfTp.sigma', EqTm.cong_pair', EqTm.cong_fst', EqTm.cong_snd'] case symm_tm' => grind [EqTm.conv_eq, EqSb.symm] - grind_cases + grind_cases -/ end SubstProof diff --git a/lake-manifest.json b/lake-manifest.json index 88e14e9d..662e80b9 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -11,41 +11,21 @@ "inputRev": null, "inherited": false, "configFile": "lakefile.lean"}, - {"url": "https://github.com/sinhp/Poly", + {"url": "https://github.com/jlh18/mathlib4", "type": "git", "subDir": null, "scope": "", - "rev": "a02b469794555cc89a75911c85e4ff60136d1490", - "name": "Poly", - "manifestFile": "lake-manifest.json", - "inputRev": "master", - "inherited": false, - "configFile": "lakefile.lean"}, - {"url": "https://github.com/Vtec234/lean4-seq", - "type": "git", - "subDir": null, - "scope": "", - "rev": "7279fc299b10681b00aefe1edd0668766cead87c", - "name": "seq", - "manifestFile": "lake-manifest.json", - "inputRev": null, - "inherited": true, - "configFile": "lakefile.lean"}, - {"url": "https://github.com/leanprover-community/mathlib4.git", - "type": "git", - "subDir": null, - "scope": "", - "rev": "839e741740619e20759a7153fd93b5c7d8df13e0", + "rev": "87d8a903c4d5ede38bf6685dede04722bbc755b4", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": null, - "inherited": true, + "inputRev": "clans", + "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "240eddc1bb31420fbbc57fe5cc579435c2522493", + "rev": "9f492660e9837df43fd885a2ad05c520da9ff9f5", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -65,7 +45,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "7c02243c07b61d493d7607ede432026781a3e47c", + "rev": "90f3b0f429411beeeb29bbc248d799c18a2d520d", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -75,17 +55,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "6e47cc88cfbf1601ab364e9a4de5f33f13401ff8", + "rev": "556caed0eadb7901e068131d1be208dd907d07a2", "name": "proofwidgets", "manifestFile": "lake-manifest.json", - "inputRev": "v0.0.71", + "inputRev": "v0.0.74", "inherited": true, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/aesop", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "3b779e9d1c73837a3764d516d81f942de391b6f0", + "rev": "9e8de5716b162ec8983a89711a186d13ff871c22", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -95,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "f85ad59c9b60647ef736719c23edd4578f723806", + "rev": "345a958916d27982d4ecb4500fba0ebb21096651", "name": "Qq", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -105,7 +85,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "a9a0cb7672b7134497c9d813e53999c9311f4037", + "rev": "3881bc95874e5843b76886ea136f4722f1fa83cf", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -115,7 +95,7 @@ "type": "git", "subDir": null, "scope": "leanprover", - "rev": "cacb481a1eaa4d7d4530a27b606c60923da21caf", + "rev": "b62fd39acc32da6fb8bb160c82d1bbc3cb3c186e", "name": "Cli", "manifestFile": "lake-manifest.json", "inputRev": "main", diff --git a/lakefile.lean b/lakefile.lean index 3e95c743..56c6621a 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 mathlib from git "https://github.com/jlh18/mathlib4" @ "clans" require checkdecls from git "https://github.com/PatrickMassot/checkdecls.git" diff --git a/lean-toolchain b/lean-toolchain index d6446672..66a6d412 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.23.0-rc2 +leanprover/lean4:v4.24.0-rc1 \ No newline at end of file From 26a94381e213a1731238a1a99bc4ab55b7c76994 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 25 Sep 2025 19:58:17 -0400 Subject: [PATCH 02/59] refactor: some of UHom --- .../ForMathlib/CategoryTheory/Polynomial.lean | 42 +- HoTTLean/Model/NaturalModel.lean | 551 +++++++++++++++++- HoTTLean/Model/UHom.lean | 457 ++++++++------- 3 files changed, 800 insertions(+), 250 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index cf76e20d..20296b08 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -9,7 +9,7 @@ import Mathlib.CategoryTheory.Functor.TwoSquare import Mathlib.CategoryTheory.NatTrans.IsCartesian import Mathlib.CategoryTheory.Comma.Over.Pushforward -universe v u +universe v u v₁ u₁ noncomputable section @@ -573,7 +573,7 @@ lemma snd_eq (pair : Γ ⟶ P @ X) : snd pair = (by simp) ≫ sndProj P X := by simpa [Limits.pullback.map] using congrArg CommaMorphism.left (MvPoly.Equiv.snd_eq (fstAux pair)) -def snd' (pair : Γ ⟶ P @ X) {R f g} (H : IsPullback (P := R) f g (fst pair) P.p) : R ⟶ X := +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) : @@ -592,7 +592,7 @@ def mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : Γ ⟶ P @ X := (MvPoly.Equiv.mk (P := P.mvPoly) (Γ := Over.mk (terminal.from Γ)) (Over.mk b) (by congr; apply terminal.hom_ext) (mkAux b x)).left -def mk' (b : Γ ⟶ B) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ X) : Γ ⟶ P @ X := +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) : @@ -606,12 +606,12 @@ lemma fst_mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : simp [← heq_eq_eq]; rfl @[simp] -lemma fst_mk' (b : Γ ⟶ B) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ X) : +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) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ X) : +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] @@ -622,22 +622,22 @@ 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) {R f g} (H : IsPullback (P := R) f g (fst pair) P.p) : +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 `R` used in `UvPoly.Equiv.snd'` with a different pullback `R'`. -/ -lemma snd'_eq_snd' (pair : Γ ⟶ P @ X) {R f g} (H : IsPullback (P := R) f g (fst pair) P.p) - {R' f' g'} (H' : IsPullback (P := R') f' g' (fst pair) P.p) : +/-- 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) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ X) : +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 sorry -- have : comparison (c := fan P X) (mk' P X b H x) ≫ _ = @@ -666,9 +666,9 @@ lemma snd_mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : apply eq_of_heq; rw [heq_eqToHom_comp_iff]; apply snd_mk_heq theorem snd'_comp_left (pair : Γ ⟶ P @ X) - {R f g} (H : IsPullback (P := R) f g (fst pair) P.p) + {pb f g} (H : IsPullback (P := pb) f g (fst pair) P.p) {Δ} (σ : Δ ⟶ Γ) - {R' f' g'} (H' : IsPullback (P := R') 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] @@ -678,7 +678,7 @@ theorem snd'_comp_left (pair : Γ ⟶ P @ X) · simp theorem snd'_comp_right (pair : Γ ⟶ P @ X) (f : X ⟶ Y) - {R f1 f2} (H : IsPullback (P := R) f1 f2 (fst pair) P.p) : + {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 sorry @@ -701,7 +701,7 @@ theorem snd_comp_right (pair : Γ ⟶ P @ X) (f : X ⟶ Y) : snd (pair ≫ P.fun sorry lemma ext' {pair₁ pair₂ : Γ ⟶ P @ X} - {R f g} (H : IsPullback (P := R) f g (fst pair₁) P.p) + {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 @@ -720,9 +720,9 @@ lemma ext' {pair₁ pair₂ : Γ ⟶ P @ X} -- simp sorry -/-- Switch the selected pullback `R` used in `UvPoly.Equiv.mk'` with a different pullback `R'`. -/ -theorem mk'_eq_mk' (b : Γ ⟶ B) {R f g} (H : IsPullback (P := R) f g b P.p) (x : R ⟶ X) - {R' f' g'} (H' : IsPullback (P := R') f' g' b P.p) : +/-- 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' P X (R := R) (f := f) (g := g) (by convert H; simp) -- · rw [snd'_eq_snd' P X (mk' P X b H' ((IsPullback.isoIsPullback _ _ H H').inv ≫ x)) @@ -733,7 +733,7 @@ theorem mk'_eq_mk' (b : Γ ⟶ B) {R f g} (H : IsPullback (P := R) f g b P.p) (x @[simp] lemma eta' (pair : Γ ⟶ P @ X) - {R f1 f2} (H : IsPullback (P := R) f1 f2 (fst pair) P.p) : + {pb f1 f2} (H : IsPullback (P := pb) f1 f2 (fst pair) P.p) : mk' (fst pair) H (snd' pair H) = pair := .symm <| ext' H (by simp) (by simp) @@ -742,7 +742,7 @@ lemma eta (pair : Γ ⟶ P @ X) : mk (fst pair) (snd pair) = pair := by simp [mk_eq_mk', snd_eq_snd'] -lemma mk'_comp_right (b : Γ ⟶ B) {R f1 f2} (H : IsPullback (P := R) f1 f2 b P.p) (x : R ⟶ X) +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 @@ -772,8 +772,8 @@ 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'} --- (y : Γ ⟶ B) (R f g) (H : IsPullback (P := R) f g y P.p.1) --- (x : R ⟶ X) (e : E ⟶ E') (b : B ⟶ B') +-- (y : Γ ⟶ B) (pb f g) (H : IsPullback (P := pb) f g y P.p.1) +-- (x : pb ⟶ X) (e : E ⟶ E') (b : B ⟶ B') -- (hp : IsPullback P.p.1 e b P'.p.1) : -- Equiv.mk' y H x ≫ (P.cartesianNatTrans P' b e hp).app X = -- Equiv.mk' P' X (y ≫ b) (H.paste_vert hp) x := by diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index 6e176179..3cedc735 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -2,7 +2,7 @@ import Mathlib.CategoryTheory.Limits.Shapes.KernelPair -- import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.Presheaf -- import Poly.UvPoly.UPFan -import HoTTLean.ForPoly +import HoTTLean.ForMathlib import HoTTLean.ForMathlib.Tactic.CategoryTheory.FunctorMap import HoTTLean.ForMathlib.CategoryTheory.Yoneda import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone @@ -224,9 +224,11 @@ Specializations of results from the `Poly` package to natural models. -/ abbrev uvPolyTp : UvPoly R M.Tm M.Ty := ⟨M.tp, M.morphismProperty⟩ -variable [HasTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] +variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] [R.HasPushforwards R] [R.IsStableUnderPushforward R] +instance : HasTerminal Ctx := IsTerminal.hasTerminal (ChosenTerminal.isTerminal) + def Ptp : Ctx ⥤ Ctx := M.uvPolyTp.functor namespace PtpEquiv @@ -781,7 +783,7 @@ Tm ----> i Tm -/ def verticalNatTrans : ie.iFunctor ⟶ (UvPoly.id R M.Tm).functor := - UvPoly.verticalNatTrans (UvPoly.id M.Tm) ie.iUvPoly + UvPoly.verticalNatTrans (UvPoly.id R M.Tm) ie.iUvPoly ie.comparison (by simp [iUvPoly]) section reflCase @@ -791,9 +793,552 @@ variable (i : IdIntro M) {N : Universe 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)) ≫ ii.toK a := by + dsimp [toK] + apply ii.isKernelPair.hom_ext + -- FIXME: `transparency := .default` is like `erw` and should be avoided + · rw! (transparency := .default) [Category.assoc] + simp + · simp only [IsKernelPair.lift_snd, Category.assoc] + slice_rhs 1 2 => rw [← Functor.map_comp, substWk_disp] + -- FIXME: `transparency := .default` is like `erw` and should be avoided + rw! (transparency := .default) [Category.assoc] + 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] + rfl + +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' ie.iUvPoly X a (ie.motiveCtx_isPullback' a).flip x + +def equivFst (pair : Γ ⟶ ie.iFunctor.obj X) : + Γ ⟶ M.Tm := + UvPoly.Equiv.fst ie.iUvPoly X 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' ie.iUvPoly X pair (ie.motiveCtx_isPullback' _).flip + +lemma equivSnd_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) + {Δ} (σ : Δ ⟶ Γ) : + ie.equivSnd (σ ≫ pair) = + (ii.motiveSubst σ _) ≫ ie.equivSnd pair := by + 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 : Universe 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) + +namespace Id + +variable {N : Universe 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 + +#exit +lemma reflCase_aux : IsPullback (𝟙 Γ) a a (UvPoly.id M.Tm).p := have : IsIso (UvPoly.id 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 M.Tm).functor.obj N.Tm := + UvPoly.Equiv.mk' (UvPoly.id M.Tm) N.Tm a (R := Γ) (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 +``` +-/ +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 +-- TODO: prove the other half of the equivalence. +-- Generalize this version so that the universe for elimination is not also `M` + +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 diff --git a/HoTTLean/Model/UHom.lean b/HoTTLean/Model/UHom.lean index 7e85fa73..448c87a7 100644 --- a/HoTTLean/Model/UHom.lean +++ b/HoTTLean/Model/UHom.lean @@ -15,73 +15,77 @@ namespace NaturalModel namespace Universe -variable {Ctx : Type u} [SmallCategory Ctx] +variable {Ctx : Type u} [Category Ctx] + {R : MorphismProperty Ctx} (M : Universe R) + [R.HasPullbacks] [R.IsStableUnderBaseChange] macro "by>" s:tacticSeq : term => `(by as_aux_lemma => $s) -structure Hom (M N : Universe Ctx) where +structure Hom (M N : Universe R) where mapTm : M.Tm ⟶ N.Tm mapTy : M.Ty ⟶ N.Ty pb : IsPullback mapTm M.tp N.tp mapTy -def Hom.id (M : Universe Ctx) : Hom M M where +def Hom.id (M : Universe R) : Hom M M where mapTm := 𝟙 _ mapTy := 𝟙 _ pb := IsPullback.of_id_fst -def Hom.comp {M N O : Universe Ctx} (α : Hom M N) (β : Hom N O) : Hom M O where +def Hom.comp {M N O : Universe R} (α : Hom M N) (β : Hom N O) : Hom M O where mapTm := α.mapTm ≫ β.mapTm mapTy := α.mapTy ≫ β.mapTy pb := α.pb.paste_horiz β.pb -def Hom.comp_assoc {M N O P : Universe Ctx} (α : Hom M N) (β : Hom N O) (γ : Hom O P) : +def Hom.comp_assoc {M N O P : Universe R} (α : Hom M N) (β : Hom N O) (γ : Hom O P) : comp (comp α β) γ = comp α (comp β γ) := by simp [comp] /-- Morphism into the representable natural transformation `M` from the pullback of `M` along a type. -/ -protected def pullbackHom (M : Universe Ctx) {Γ : Ctx} (A : y(Γ) ⟶ M.Ty) : +protected def pullbackHom (M : Universe R) {Γ : Ctx} (A : (Γ) ⟶ M.Ty) : Hom (M.pullback A) M where mapTm := M.var A mapTy := A pb := M.disp_pullback A -/-- Given `M : Universe`, a semantic type `A : y(Γ) ⟶ M.Ty`, +/-- Given `M : Universe`, a semantic type `A : (Γ) ⟶ M.Ty`, and a substitution `σ : Δ ⟶ Γ`, construct a Hom for the substitution `A[σ]`. -/ -def Hom.subst (M : Universe Ctx) - {Γ Δ : Ctx} (A : y(Γ) ⟶ M.Ty) (σ : Δ ⟶ Γ) : - Hom (M.pullback (ym(σ) ≫ A)) (M.pullback A) := - let Aσ := ym(σ) ≫ A +def Hom.subst (M : Universe R) + {Γ Δ : Ctx} (A : (Γ) ⟶ M.Ty) (σ : Δ ⟶ Γ) : + Hom (M.pullback ((σ) ≫ A)) (M.pullback A) := + let Aσ := (σ) ≫ A { mapTm := - (M.disp_pullback A).lift (M.var Aσ) ym(M.disp Aσ ≫ σ) (by aesop_cat) - mapTy := ym(σ) + (M.disp_pullback A).lift (M.var Aσ) (M.disp Aσ ≫ σ) (by aesop_cat) + mapTy := (σ) pb := by - convert IsPullback.of_right' (M.disp_pullback Aσ) (M.disp_pullback A) - simp } + convert IsPullback.of_right' (M.disp_pullback Aσ) (M.disp_pullback A)} -def Hom.cartesianNatTrans {M N : Universe Ctx} (h : Hom M N) : +variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] + [R.HasPushforwards R] [R.IsStableUnderPushforward R] + +def Hom.cartesianNatTrans {M N : Universe R} (h : Hom M N) : M.Ptp ⟶ N.Ptp := M.uvPolyTp.cartesianNatTrans N.uvPolyTp h.mapTy h.mapTm h.pb.flip -@[simp] def Hom.extIsoExt {M N : Universe Ctx} (h : Hom M N) - {Γ} (A : y(Γ) ⟶ M.Ty) : y(N.ext (A ≫ h.mapTy)) ≅ y(M.ext A) := - IsPullback.isoIsPullback N.Tm y(Γ) (N.disp_pullback (A ≫ h.mapTy)) +@[simp] def Hom.extIsoExt {M N : Universe R} (h : Hom M N) + {Γ} (A : (Γ) ⟶ M.Ty) : (N.ext (A ≫ h.mapTy)) ≅ (M.ext A) := + IsPullback.isoIsPullback N.Tm (Γ) (N.disp_pullback (A ≫ h.mapTy)) (IsPullback.paste_horiz (M.disp_pullback A) h.pb) @[reassoc] -theorem Hom.mk_comp_cartesianNatTrans {M N : Universe Ctx} (h : Hom M N) - {Γ X} (A : y(Γ) ⟶ M.Ty) (B : y(M.ext A) ⟶ X) : +theorem Hom.mk_comp_cartesianNatTrans {M N : Universe R} (h : Hom M N) + {Γ X} (A : (Γ) ⟶ M.Ty) (B : (M.ext A) ⟶ X) : PtpEquiv.mk M A B ≫ h.cartesianNatTrans.app X = - PtpEquiv.mk N (A ≫ h.mapTy) ((h.extIsoExt A).hom ≫ B) := by - simp [PtpEquiv.mk] - have := UvPoly.Equiv.mk'_comp_cartesianNatTrans_app M.uvPolyTp (P' := N.uvPolyTp) - A _ _ _ (M.disp_pullback _).flip B h.mapTm h.mapTy h.pb.flip - refine this.trans ?_ - simp [UvPoly.Equiv.mk']; congr 1 - rw [← Category.assoc]; congr 1 - generalize_proofs _ h1 - apply h1.hom_ext <;> simp + PtpEquiv.mk N (A ≫ h.mapTy) ((h.extIsoExt A).hom ≫ B) := by sorry + -- simp [PtpEquiv.mk] + -- have := UvPoly.Equiv.mk'_comp_cartesianNatTrans_app M.uvPolyTp (P' := N.uvPolyTp) + -- A _ _ _ (M.disp_pullback _).flip B h.mapTm h.mapTy h.pb.flip + -- refine this.trans ?_ + -- simp [UvPoly.Equiv.mk']; congr 1 + -- rw [← Category.assoc]; congr 1 + -- generalize_proofs _ h1 + -- apply h1.hom_ext <;> simp /- We have a 'nice', specific terminal object in `Ctx`, and this instance allows use to use it directly @@ -96,46 +100,46 @@ These don't form a category since `UHom.id M` is essentially `Type : Type` in `M Note this doesn't need to extend `Hom` as none of its fields are used; it's just convenient to pack up the data. -/ -structure UHom (M N : Universe Ctx) extends Hom M N where - U : y(𝟭_ Ctx) ⟶ N.Ty +structure UHom (M N : Universe R) extends Hom M N where + U : ChosenTerminal.terminal ⟶ N.Ty asTm : M.Ty ⟶ N.Tm U_pb : IsPullback /- m.Ty -/ asTm /- N.Tm -/ - (isTerminal_yUnit.from M.Ty) N.tp + (ChosenTerminal.isTerminal.from M.Ty) N.tp /- ⊤ -/ U /- N.Ty -/ def UHom.ofTyIsoExt - {M N : Universe Ctx} - (H : Hom M N) {U : y(𝟭_ Ctx) ⟶ N.Ty} (i : M.Ty ≅ y(N.ext U)) : + {M N : Universe R} + (H : Hom M N) {U : (𝟭_ Ctx) ⟶ N.Ty} (i : M.Ty ≅ (N.ext U)) : UHom M N where __ := H U := U asTm := i.hom ≫ N.var U U_pb := by convert IsPullback.of_iso_isPullback (N.disp_pullback _) i - apply isTerminal_yUnit.hom_ext + apply ChosenTerminal.isTerminal.hom_ext -def UHom.comp {M N O : Universe Ctx} (α : UHom M N) (β : UHom N O) : UHom M O where +def UHom.comp {M N O : Universe R} (α : UHom M N) (β : UHom N O) : UHom M O where __ := Hom.comp α.toHom β.toHom U := α.U ≫ β.mapTy asTm := α.asTm ≫ β.mapTm U_pb := α.U_pb.paste_horiz β.pb -def UHom.comp_assoc {M N O P : Universe Ctx} (α : UHom M N) (β : UHom N O) (γ : UHom O P) : +def UHom.comp_assoc {M N O P : Universe R} (α : UHom M N) (β : UHom N O) (γ : UHom O P) : comp (comp α β) γ = comp α (comp β γ) := by simp [comp, Hom.comp] -def UHom.wkU {M N : Universe Ctx} (Γ : Ctx) (α : UHom M N) : y(Γ) ⟶ N.Ty := - isTerminal_yUnit.from y(Γ) ≫ α.U +def UHom.wkU {M N : Universe R} (Γ : Ctx) (α : UHom M N) : (Γ) ⟶ N.Ty := + ChosenTerminal.isTerminal.from Γ ≫ α.U @[reassoc (attr := simp)] -theorem UHom.comp_wkU {M N : Universe Ctx} {Δ Γ : Ctx} (α : UHom M N) (f : y(Δ) ⟶ y(Γ)) : +theorem UHom.comp_wkU {M N : Universe R} {Δ Γ : Ctx} (α : UHom M N) (f : (Δ) ⟶ (Γ)) : f ≫ α.wkU Γ = α.wkU Δ := by simp [wkU] /- Sanity check: construct a `UHom` into a natural model with a Tarski universe. -/ -def UHom.ofTarskiU (M : Universe Ctx) (U : y(𝟭_ Ctx) ⟶ M.Ty) (El : y(M.ext U) ⟶ M.Ty) : +def UHom.ofTarskiU (M : Universe R) (U : (𝟭_ Ctx) ⟶ M.Ty) (El : (M.ext U) ⟶ M.Ty) : UHom (M.pullback El) M where __ := M.pullbackHom El U @@ -145,32 +149,32 @@ def UHom.ofTarskiU (M : Universe Ctx) (U : y(𝟭_ Ctx) ⟶ M.Ty) (El : y(M.ext (Iso.refl _) (Iso.refl _) (Iso.refl _) - (by simp) (isTerminal_yUnit.hom_ext ..) + (by simp) (ChosenTerminal.isTerminal.hom_ext ..) (by simp) (by simp) /-! ## Universe embeddings -/ -variable (Ctx) in +variable (R) in /-- A sequence of Russell universe embeddings. -/ structure UHomSeq where /-- Number of embeddings in the sequence, or one less than the number of models in the sequence. -/ length : Nat - objs (i : Nat) (h : i < length + 1) : Universe Ctx + objs (i : Nat) (h : i < length + 1) : Universe R homSucc' (i : Nat) (h : i < length) : UHom (objs i <| by omega) (objs (i + 1) <| by omega) namespace UHomSeq -variable (s : UHomSeq Ctx) +variable (s : UHomSeq R) -instance : GetElem (UHomSeq Ctx) Nat (Universe Ctx) (fun s i => i < s.length + 1) where +instance : GetElem (UHomSeq R) Nat (Universe R) (fun s i => i < s.length + 1) where getElem s i h := s.objs i h def homSucc (i : Nat) (h : i < s.length := by get_elem_tactic) : UHom s[i] s[i+1] := s.homSucc' i h /-- Composition of embeddings between `i` and `j` in the chain. -/ -def hom (s : UHomSeq Ctx) (i j : Nat) (ij : i < j := by omega) +def hom (s : UHomSeq R) (i j : Nat) (ij : i < j := by omega) (jlen : j < s.length + 1 := by get_elem_tactic) : UHom s[i] s[j] := if h : i + 1 = j then h ▸ s.homSucc i @@ -200,33 +204,33 @@ def unlift (i j) (ij : i ≤ j := by omega) (jlen : j < s.length + 1 := by get_e @[simp] theorem unlift_tp {i j ij jlen Γ A} - {t : y(Γ) ⟶ _} (eq : t ≫ s[j].tp = A ≫ (s.homOfLe i j).mapTy) : + {t : (Γ) ⟶ _} (eq : t ≫ s[j].tp = A ≫ (s.homOfLe i j).mapTy) : s.unlift i j ij jlen A t eq ≫ (s[i]'(ij.trans_lt jlen)).tp = A := by simp [unlift] @[simp] theorem unlift_lift {i j ij jlen Γ A} - {t : y(Γ) ⟶ _} (eq : t ≫ s[j].tp = A ≫ (s.homOfLe i j).mapTy) : + {t : (Γ) ⟶ _} (eq : t ≫ s[j].tp = A ≫ (s.homOfLe i j).mapTy) : s.unlift i j ij jlen A t eq ≫ (s.homOfLe i j).mapTm = t := by simp [unlift] def unliftVar (i j) (ij : i ≤ j := by omega) (jlen : j < s.length + 1 := by get_elem_tactic) - {Γ} (A : y(Γ) ⟶ (s[i]'(ij.trans_lt jlen)).Ty) - {A' : y(Γ) ⟶ s[j].Ty} (eq : A ≫ (s.homOfLe i j).mapTy = A') : - y(s[j].ext A') ⟶ (s[i]'(ij.trans_lt jlen)).Tm := - s.unlift i j ij jlen (ym(s[j].disp _) ≫ A) (s[j].var _) (by simp [eq]) + {Γ} (A : (Γ) ⟶ (s[i]'(ij.trans_lt jlen)).Ty) + {A' : (Γ) ⟶ s[j].Ty} (eq : A ≫ (s.homOfLe i j).mapTy = A') : + (s[j].ext A') ⟶ (s[i]'(ij.trans_lt jlen)).Tm := + s.unlift i j ij jlen ((s[j].disp _) ≫ A) (s[j].var _) (by simp [eq]) @[simp] -theorem unliftVar_tp {i j ij jlen Γ A} {A' : y(Γ) ⟶ s[j].Ty} +theorem unliftVar_tp {i j ij jlen Γ A} {A' : (Γ) ⟶ s[j].Ty} (eq : A ≫ (s.homOfLe i j).mapTy = A') : - s.unliftVar i j ij jlen A eq ≫ (s[i]'(ij.trans_lt jlen)).tp = ym(s[j].disp _) ≫ A := by + s.unliftVar i j ij jlen A eq ≫ (s[i]'(ij.trans_lt jlen)).tp = (s[j].disp _) ≫ A := by simp [unliftVar] -theorem substCons_unliftVar {i j ij jlen Γ A} {A' : y(Γ) ⟶ s[j].Ty} +theorem substCons_unliftVar {i j ij jlen Γ A} {A' : (Γ) ⟶ s[j].Ty} {eq : A ≫ (s.homOfLe i j).mapTy = A'} - {Δ} {σ : Δ ⟶ Γ} {t : y(Δ) ⟶ _} - (t_tp : t ≫ (s[i]'(ij.trans_lt jlen)).tp = ym(σ) ≫ A) : - ym(s[j].substCons σ A' (t ≫ (s.homOfLe i j ij jlen).mapTm) (by + {Δ} {σ : Δ ⟶ Γ} {t : (Δ) ⟶ _} + (t_tp : t ≫ (s[i]'(ij.trans_lt jlen)).tp = (σ) ≫ A) : + (s[j].substCons σ A' (t ≫ (s.homOfLe i j ij jlen).mapTm) (by simp [*] conv_lhs => rhs; apply (s.homOfLe i j).pb.w subst A'; rw [← Category.assoc, ← Category.assoc, ← t_tp])) @@ -243,11 +247,11 @@ def cartesianNatTrans (i j : Nat) (s.homOfLe i j).cartesianNatTrans @[reassoc] -theorem mk_comp_cartesianNatTrans {i j ij jlen} {Γ X} (A : y(Γ) ⟶ s[i].Ty) - (B : y(s[i].ext A) ⟶ X) : +theorem mk_comp_cartesianNatTrans {i j ij jlen} {Γ X} (A : (Γ) ⟶ s[i].Ty) + (B : (s[i].ext A) ⟶ X) : PtpEquiv.mk s[i] A B ≫ (s.cartesianNatTrans i j).app X = PtpEquiv.mk s[j] (A ≫ (s.homOfLe i j).mapTy) - (ym(substCons _ (s[j].disp _) _ (s.unliftVar i j ij jlen A rfl) (by simp)) ≫ B) := by + ((substCons _ (s[j].disp _) _ (s.unliftVar i j ij jlen A rfl) (by simp)) ≫ B) := by convert Hom.mk_comp_cartesianNatTrans _ _ _ apply (IsPullback.paste_horiz (s[i].disp_pullback _) (s.homOfLe i j).pb).hom_ext · simp [unliftVar] @@ -257,7 +261,8 @@ theorem cartesianNatTrans_fstProj {i j ij jlen X} : (s.cartesianNatTrans i j ij jlen).app X ≫ s[j].uvPolyTp.fstProj X = s[i].uvPolyTp.fstProj X ≫ (s.homOfLe i j ij jlen).mapTy := by unfold cartesianNatTrans - apply UvPoly.cartesianNatTrans_fstProj + -- apply UvPoly.cartesianNatTrans_fstProj + sorry /-- This is one side of the commutative square @@ -280,10 +285,10 @@ def cartesianNatTransTm (i0 i1 j0 j1 : Nat) s[i1].Ptp.map (s.homOfLe j0 j1).mapTm theorem mk_comp_cartesianNatTransTm {i0 i1 j0 j1 ii ilen jj jlen} - {Γ X} (A : y(Γ) ⟶ s[i0].Ty) (B : y(s[i0].ext A) ⟶ s[j0].Tm) + {Γ X} (A : (Γ) ⟶ s[i0].Ty) (B : (s[i0].ext A) ⟶ s[j0].Tm) : PtpEquiv.mk s[i0] A B ≫ s.cartesianNatTransTm i0 i1 j0 j1 ii ilen jj jlen = PtpEquiv.mk s[i1] (A ≫ (s.homOfLe i0 i1).mapTy) - (ym(substCons _ (s[i1].disp _) _ (s.unliftVar i0 i1 ii ilen A rfl) (by simp)) + ((substCons _ (s[i1].disp _) _ (s.unliftVar i0 i1 ii ilen A rfl) (by simp)) ≫ B ≫ (s.homOfLe j0 j1).mapTm) := by simp [cartesianNatTransTm, mk_comp_cartesianNatTrans_assoc, PtpEquiv.mk_map] @@ -302,10 +307,10 @@ def cartesianNatTransTy (i0 i1 j0 j1 : Nat) s[i1].Ptp.map (s.homOfLe j0 j1).mapTy theorem mk_comp_cartesianNatTransTy {i0 i1 j0 j1 ii ilen jj jlen} - {Γ X} (A : y(Γ) ⟶ s[i0].Ty) (B : y(s[i0].ext A) ⟶ s[j0].Ty) + {Γ X} (A : (Γ) ⟶ s[i0].Ty) (B : (s[i0].ext A) ⟶ s[j0].Ty) : PtpEquiv.mk s[i0] A B ≫ s.cartesianNatTransTy i0 i1 j0 j1 ii ilen jj jlen = PtpEquiv.mk s[i1] (A ≫ (s.homOfLe i0 i1).mapTy) - (ym(substCons _ (s[i1].disp _) _ (s.unliftVar i0 i1 ii ilen A rfl) (by simp)) + ((substCons _ (s[i1].disp _) _ (s.unliftVar i0 i1 ii ilen A rfl) (by simp)) ≫ B ≫ (s.homOfLe j0 j1).mapTy) := by simp [cartesianNatTransTy, mk_comp_cartesianNatTrans_assoc, PtpEquiv.mk_map] @@ -316,7 +321,7 @@ theorem cartesianNatTransTy_fstProj {i0 i1 j0 j1 ii ilen jj jlen} : slice_lhs 2 3 => apply UvPoly.map_fstProj apply cartesianNatTrans_fstProj -theorem hom_comp_trans (s : UHomSeq Ctx) (i j k : Nat) (ij : i < j) (jk : j < k) +theorem hom_comp_trans (s : UHomSeq R) (i j k : Nat) (ij : i < j) (jk : j < k) (klen : k < s.length + 1) : (s.hom i j ij).comp (s.hom j k jk) = s.hom i k (ij.trans jk) := by conv_rhs => unfold hom @@ -340,21 +345,21 @@ It is defined by composition with the first projection of the pullback square A / | p.b. | / | | / V V -y(Γ) ---> 1 -----> s[i+1].Ty +(Γ) ---> 1 -----> s[i+1].Ty U_i -/ -def code {Γ : Ctx} {i : Nat} (s : UHomSeq Ctx) (ilen : i < s.length) (A : y(Γ) ⟶ s[i].Ty) : - y(Γ) ⟶ s[i+1].Tm := +def code {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : + (Γ) ⟶ s[i+1].Tm := A ≫ (s.homSucc i).asTm @[simp] -theorem code_tp {Γ : Ctx} {i : Nat} (s : UHomSeq Ctx) (ilen : i < s.length) (A : y(Γ) ⟶ s[i].Ty) : +theorem code_tp {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : s.code ilen A ≫ s[i+1].tp = (s.homSucc i).wkU Γ := by simp [code, (s.homSucc i).U_pb.w, UHom.wkU] @[reassoc] -theorem comp_code {Δ Γ : Ctx} {i : Nat} (s : UHomSeq Ctx) (ilen : i < s.length) - (σ : y(Δ) ⟶ y(Γ)) (A : y(Γ) ⟶ s[i].Ty) : +theorem comp_code {Δ Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) + (σ : (Δ) ⟶ (Γ)) (A : (Γ) ⟶ s[i].Ty) : σ ≫ s.code ilen A = s.code ilen (σ ≫ A) := by simp [code] @@ -364,35 +369,35 @@ Convert a a term of the `i`th universe (it is a `i+1` level term) into a map into the `i`th type classifier. It is the unique map into the pullback a -y(Γ) -----------------¬ +(Γ) -----------------¬ ‖ --> v V ‖ s[i].Ty ----> s[i+1].Tm ‖ | | ‖ | p.b. | ‖ | | ‖ V V -y(Γ) ---> 1 -----> s[i+1].Ty +(Γ) ---> 1 -----> s[i+1].Ty U_i -/ -def el (s : UHomSeq Ctx) {Γ : Ctx} {i : Nat} (ilen : i < s.length) - (a : y(Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : - y(Γ) ⟶ s[i].Ty := - (s.homSucc i).U_pb.lift a (isTerminal_yUnit.from y(Γ)) (by rw [a_tp, UHom.wkU]) +def el (s : UHomSeq R) {Γ : Ctx} {i : Nat} (ilen : i < s.length) + (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : + (Γ) ⟶ s[i].Ty := + (s.homSucc i).U_pb.lift a (ChosenTerminal.isTerminal.from (Γ)) (by rw [a_tp, UHom.wkU]) @[reassoc] -theorem comp_el (s : UHomSeq Ctx) {Δ Γ : Ctx} {i : Nat} (ilen : i < s.length) - (σ : y(Δ) ⟶ y(Γ)) (a : y(Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : +theorem comp_el (s : UHomSeq R) {Δ Γ : Ctx} {i : Nat} (ilen : i < s.length) + (σ : (Δ) ⟶ (Γ)) (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : σ ≫ s.el ilen a a_tp = s.el ilen (σ ≫ a) (by simp [a_tp]) := (s.homSucc i).U_pb.hom_ext (by simp [el]) (by simp) @[simp] -lemma el_code {Γ : Ctx} {i : Nat} (s : UHomSeq Ctx) (ilen : i < s.length) (A : y(Γ) ⟶ s[i].Ty) : +lemma el_code {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : el s ilen (code s ilen A) (code_tp _ _ _) = A := (s.homSucc i).U_pb.hom_ext (by simp [el, code]) (by simp) @[simp] -lemma code_el (s : UHomSeq Ctx) {Γ : Ctx} {i : Nat} (ilen : i < s.length) - (a : y(Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : +lemma code_el (s : UHomSeq R) {Γ : Ctx} {i : Nat} (ilen : i < s.length) + (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : code s ilen (el s ilen a a_tp) = a := by simp [code, el] @@ -419,7 +424,7 @@ can be extended to -------------------------- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ΠA. B type ``` -/ -protected class PiSeq (s : UHomSeq Ctx) where +protected class PiSeq (s : UHomSeq R) where nmPi (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : Universe.Pi s[i] section Pi @@ -454,13 +459,13 @@ def Pi_pb : ----------------- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ΠA. B ``` -/ -def mkPi {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) : y(Γ) ⟶ s[max i j].Ty := +def mkPi {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : (Γ) ⟶ s[max i j].Ty := PtpEquiv.mk s[i] A B ≫ s.Pi ilen jlen theorem comp_mkPi {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (σA) (eq : ym(σ) ≫ A = σA) - (B : y(s[i].ext A) ⟶ s[j].Ty) : - ym(σ) ≫ s.mkPi ilen jlen A B = s.mkPi ilen jlen σA (ym(s[i].substWk σ A _ eq) ≫ B) := by + (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) + (B : (s[i].ext A) ⟶ s[j].Ty) : + (σ) ≫ s.mkPi ilen jlen A B = s.mkPi ilen jlen σA ((s[i].substWk σ A _ eq) ≫ B) := by simp [mkPi, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] /-- @@ -469,18 +474,18 @@ theorem comp_mkPi {Δ Γ : Ctx} (σ : Δ ⟶ Γ) ------------------------- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ λA. t : ΠA. B ``` -/ -def mkLam {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (t : y(s[i].ext A) ⟶ s[j].Tm) : y(Γ) ⟶ s[max i j].Tm := +def mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (t : (s[i].ext A) ⟶ s[j].Tm) : (Γ) ⟶ s[max i j].Tm := PtpEquiv.mk s[i] A t ≫ s.lam ilen jlen @[simp] -theorem mkLam_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (t : y(s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) : +theorem mkLam_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (t : (s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) : s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B := by simp [mkLam, mkPi, (s.Pi_pb ilen jlen).w, PtpEquiv.mk_map_assoc, t_tp] theorem comp_mkLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (σA) (eq : ym(σ) ≫ A = σA) (t : y(s[i].ext A) ⟶ s[j].Tm) : - ym(σ) ≫ s.mkLam ilen jlen A t = s.mkLam ilen jlen σA (ym(s[i].substWk σ A _ eq) ≫ t) := by + (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) (t : (s[i].ext A) ⟶ s[j].Tm) : + (σ) ≫ s.mkLam ilen jlen A t = s.mkLam ilen jlen σA ((s[i].substWk σ A _ eq) ≫ t) := by simp [mkLam, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] @@ -490,10 +495,10 @@ theorem comp_mkLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) ----------------------------- Γ.A ⊢ⱼ unlam f : B ``` -/ -def unLam {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - y(s[i].ext A) ⟶ s[j].Tm := by - let total : y(Γ) ⟶ s[i].Ptp.obj s[j].Tm := +def unLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : + (s[i].ext A) ⟶ s[j].Tm := by + let total : (Γ) ⟶ s[i].Ptp.obj s[j].Tm := (s.Pi_pb ilen jlen).lift f (PtpEquiv.mk s[i] A B) f_tp refine PtpEquiv.snd s[i] total _ ?_ have eq : total ≫ s[i].Ptp.map s[j].tp = PtpEquiv.mk s[i] A B := @@ -503,18 +508,18 @@ def unLam {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) simpa using eq @[simp] -theorem unLam_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +theorem unLam_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : s.unLam ilen jlen A B f f_tp ≫ s[j].tp = B := by rw [unLam, ← PtpEquiv.snd_comp_right] convert PtpEquiv.snd_mk s[i] A B using 2; simp theorem comp_unLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (σA) (eq : ym(σ) ≫ A = σA) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - ym(s[i].substWk σ A _ eq) ≫ s.unLam ilen jlen A B f f_tp = - s.unLam ilen jlen σA (ym(s[i].substWk σ A _ eq) ≫ B) - (ym(σ) ≫ f) (by simp [eq, f_tp, comp_mkPi]) := by + (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : + (s[i].substWk σ A _ eq) ≫ s.unLam ilen jlen A B f f_tp = + s.unLam ilen jlen σA ((s[i].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 @@ -528,34 +533,34 @@ theorem comp_unLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) --------------------------------- Γ ⊢ⱼ f a : B[id.a] ``` -/ -def mkApp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : y(Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : y(Γ) ⟶ s[j].Tm := - ym(s[i].sec A a a_tp) ≫ s.unLam ilen jlen A B f f_tp +def mkApp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) + (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : (Γ) ⟶ s[j].Tm := + (s[i].sec A a a_tp) ≫ s.unLam ilen jlen A B f f_tp @[simp] -theorem mkApp_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : y(Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : - s.mkApp ilen jlen A B f f_tp a a_tp ≫ s[j].tp = ym(s[i].sec A a a_tp) ≫ B := by +theorem mkApp_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) + (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : + s.mkApp ilen jlen A B f f_tp a a_tp ≫ s[j].tp = (s[i].sec A a a_tp) ≫ B := by simp [mkApp] theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (σA) (eq : ym(σ) ≫ A = σA) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : y(Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : - ym(σ) ≫ s.mkApp ilen jlen A B f f_tp a a_tp = - s.mkApp ilen jlen σA (ym(s[i].substWk σ A _ eq) ≫ B) - (ym(σ) ≫ f) (by simp [f_tp, comp_mkPi (eq := eq)]) - (ym(σ) ≫ a) (by simp [a_tp, eq]) := by + (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) + (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : + (σ) ≫ s.mkApp ilen jlen A B f f_tp a a_tp = + s.mkApp ilen jlen σA ((s[i].substWk σ A _ eq) ≫ B) + ((σ) ≫ f) (by simp [f_tp, comp_mkPi (eq := eq)]) + ((σ) ≫ a) (by simp [a_tp, eq]) := by unfold mkApp; rw [← Functor.map_comp_assoc, comp_sec (eq := eq), Functor.map_comp_assoc, comp_unLam (eq := eq)] @[simp] -theorem mkLam_unLam {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +theorem mkLam_unLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : s.mkLam ilen jlen A (s.unLam ilen jlen A B f f_tp) = f := by - let total : y(Γ) ⟶ s[i].Ptp.obj s[j].Tm := + let total : (Γ) ⟶ s[i].Ptp.obj s[j].Tm := (s.Pi_pb ilen jlen).lift f (PtpEquiv.mk s[i] A B) f_tp simp [mkLam, unLam] have : PtpEquiv.fst s[i] total = A := by @@ -568,8 +573,8 @@ theorem mkLam_unLam {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[ apply (s.Pi_pb ilen jlen).lift_fst @[simp] -theorem unLam_mkLam {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (t : y(s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) +theorem unLam_mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (t : (s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) (lam_tp : s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B) : s.unLam ilen jlen A B (s.mkLam ilen jlen A t) lam_tp = t := by simp [mkLam, unLam] @@ -584,17 +589,17 @@ theorem unLam_mkLam {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[ Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ λA. f[↑] v₀ : ΠA. B ``` -/ -def etaExpand {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - y(Γ) ⟶ s[max i j].Tm := +def etaExpand {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : + (Γ) ⟶ s[max i j].Tm := s.mkLam ilen jlen A <| s.mkApp ilen jlen - (ym(s[i].disp A) ≫ A) (ym(s[i].substWk ..) ≫ B) (ym(s[i].disp A) ≫ f) + ((s[i].disp A) ≫ A) ((s[i].substWk ..) ≫ B) ((s[i].disp A) ≫ f) (by simp [f_tp, comp_mkPi]) (s[i].var A) (s[i].var_tp A) -theorem etaExpand_eq {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (f : y(Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +theorem etaExpand_eq {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : s.etaExpand ilen jlen A B f f_tp = f := by simp [etaExpand] convert s.mkLam_unLam ilen jlen A B f f_tp using 2 @@ -611,11 +616,11 @@ theorem etaExpand_eq {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s Γ.A ⊢ⱼ (λA. t) a ≡ t[a] : B[a] ``` -/ @[simp] -theorem mkApp_mkLam {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (t : y(s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) +theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (t : (s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) (lam_tp : s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : y(Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : - s.mkApp ilen jlen A B (s.mkLam ilen jlen A t) lam_tp a a_tp = ym(s[i].sec A a a_tp) ≫ t := by + (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : + s.mkApp ilen jlen A B (s.mkLam ilen jlen A t) lam_tp a a_tp = (s[i].sec A a a_tp) ≫ t := by rw [mkApp, unLam_mkLam] assumption @@ -624,7 +629,7 @@ end Pi /-! ## Sigma -/ /-- The data of `Sig` and `pair` formers at each universe `s[i].tp`. -/ -class SigSeq (s : UHomSeq Ctx) where +class SigSeq (s : UHomSeq R) where nmSig (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : Universe.Sigma s[i] section Sigma @@ -657,14 +662,14 @@ def Sig_pb : IsPullback ----------------- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ΣA. B ``` -/ -def mkSig {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) : - y(Γ) ⟶ s[max i j].Ty := +def mkSig {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : + (Γ) ⟶ s[max i j].Ty := PtpEquiv.mk s[i] A B ≫ s.Sig ilen jlen theorem comp_mkSig {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) : - ym(σ) ≫ s.mkSig ilen jlen A B = - s.mkSig ilen jlen (ym(σ) ≫ A) (ym(s[i].substWk σ A) ≫ B) := by + (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : + (σ) ≫ s.mkSig ilen jlen A B = + s.mkSig ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) := by simp [mkSig, ← Category.assoc, PtpEquiv.mk_comp_left] /-- @@ -673,76 +678,76 @@ theorem comp_mkSig {Δ Γ : Ctx} (σ : Δ ⟶ Γ) -------------------------- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ⟨t, u⟩ : ΣA. B ``` -/ -def mkPair {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (t : y(Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : y(Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = ym(s[i].sec A t t_tp) ≫ B) : - y(Γ) ⟶ s[max i j].Tm := +def mkPair {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) + (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : + (Γ) ⟶ s[max i j].Tm := compDomEquiv.mk t t_tp B u u_tp ≫ s.pair ilen jlen theorem comp_mkPair {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (t : y(Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : y(Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = ym(s[i].sec A t t_tp) ≫ B) : - ym(σ) ≫ s.mkPair ilen jlen A B t t_tp u u_tp = - s.mkPair ilen jlen (ym(σ) ≫ A) (ym(s[i].substWk σ A) ≫ B) - (ym(σ) ≫ t) (by simp [t_tp]) - (ym(σ) ≫ u) (by simp [u_tp, comp_sec_functor_map_assoc]) := by + (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) + (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : + (σ) ≫ s.mkPair ilen jlen A B t t_tp u u_tp = + s.mkPair ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) + ((σ) ≫ t) (by simp [t_tp]) + ((σ) ≫ u) (by simp [u_tp, comp_sec_functor_map_assoc]) := by simp only [← Category.assoc, mkPair]; rw [compDomEquiv.comp_mk] @[simp] -theorem mkPair_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (t : y(Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : y(Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = ym(s[i].sec A t t_tp) ≫ B) : +theorem mkPair_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) + (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : s.mkPair ilen jlen A B t t_tp u u_tp ≫ s[max i j].tp = s.mkSig ilen jlen A B := by simp [mkPair, mkSig, UvPoly.compP, (s.Sig_pb ilen jlen).w, compDomEquiv.mk] -def mkFst {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (p : y(Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - y(Γ) ⟶ s[i].Tm := +def mkFst {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : + (Γ) ⟶ s[i].Tm := compDomEquiv.fst ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk _ A B) p_tp) @[simp] -theorem mkFst_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (p : y(Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +theorem mkFst_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : s.mkFst ilen jlen A B p p_tp ≫ s[i].tp = A := by simp [mkFst, UvPoly.compP, compDomEquiv.fst_tp] @[simp] -theorem mkFst_mkPair {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (t : y(Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : y(Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = ym(s[i].sec A t t_tp) ≫ B) : +theorem mkFst_mkPair {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) + (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : s.mkFst ilen jlen A B (s.mkPair ilen jlen 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_pb ilen jlen).hom_ext <;> [simp; simp [compDomEquiv.mk, UvPoly.compP]] theorem comp_mkFst {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (p : y(Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - ym(σ) ≫ s.mkFst ilen jlen A B p p_tp = - s.mkFst ilen jlen (ym(σ) ≫ A) (ym(s[i].substWk σ A) ≫ B) (ym(σ) ≫ p) + (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : + (σ) ≫ s.mkFst ilen jlen A B p p_tp = + s.mkFst ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) ((σ) ≫ p) (by simp [p_tp, comp_mkSig]) := by simp [mkFst] rw [compDomEquiv.comp_fst]; congr 1 apply (s.Sig_pb ilen jlen).hom_ext <;> simp rw [PtpEquiv.mk_comp_left] -def mkSnd {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (p : y(Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - y(Γ) ⟶ s[j].Tm := +def mkSnd {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : + (Γ) ⟶ s[j].Tm := compDomEquiv.snd ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk _ A B) p_tp) @[simp] -theorem mkSnd_mkPair {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (t : y(Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : y(Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = ym(s[i].sec A t t_tp) ≫ B) : +theorem mkSnd_mkPair {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) + (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : s.mkSnd ilen jlen A B (s.mkPair ilen jlen 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_pb ilen jlen).hom_ext <;> [simp; simp [compDomEquiv.mk, UvPoly.compP]] -protected theorem dependent_eq {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (p : y(Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +protected theorem dependent_eq {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : compDomEquiv.dependent ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk s[i] A B) p_tp) A (by simp [compDomEquiv.fst_tp]) = B := by simp [compDomEquiv.dependent, -UvPoly.comp_p] @@ -750,26 +755,26 @@ protected theorem dependent_eq {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ex simp @[simp] -theorem mkSnd_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (p : y(Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +theorem mkSnd_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : s.mkSnd ilen jlen A B p p_tp ≫ s[j].tp = - ym(s[i].sec A (s.mkFst ilen jlen A B p p_tp) (by simp)) ≫ B := by + (s[i].sec A (s.mkFst ilen jlen 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 : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (p : y(Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - ym(σ) ≫ s.mkSnd ilen jlen A B p p_tp = - s.mkSnd ilen jlen (ym(σ) ≫ A) (ym(s[i].substWk σ A) ≫ B) (ym(σ) ≫ p) + (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : + (σ) ≫ s.mkSnd ilen jlen A B p p_tp = + s.mkSnd ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) ((σ) ≫ p) (by simp [p_tp, comp_mkSig]) := by simp [mkSnd, compDomEquiv.comp_snd]; congr 1 apply (s.Sig_pb ilen jlen).hom_ext <;> simp rw [PtpEquiv.mk_comp_left] @[simp] -theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (B : y(s[i].ext A) ⟶ s[j].Ty) - (p : y(Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : s.mkPair ilen jlen A B (s.mkFst ilen jlen A B p p_tp) (by simp) (s.mkSnd ilen jlen A B p p_tp) (by simp) = p := by @@ -783,7 +788,7 @@ end Sigma /-! ## Identity types -/ -class IdSeq (s : UHomSeq Ctx) where +class IdSeq (s : UHomSeq R) where nmII (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : Universe.IdIntro s[i] nmIEB (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : Universe.IdElimBase (nmII i ilen) @@ -800,17 +805,17 @@ variable [s.IdSeq] ----------------------- Γ ⊢ᵢ Id(A, a0, a1) ``` -/ -def mkId {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) (a0 a1 : y(Γ) ⟶ s[i].Tm) +def mkId {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (a0 a1 : (Γ) ⟶ s[i].Tm) (a0_tp : a0 ≫ s[i].tp = A) (a1_tp : a1 ≫ s[i].tp = A) : - y(Γ) ⟶ s[i].Ty := + (Γ) ⟶ s[i].Ty := (nmII i).mkId a0 a1 (a1_tp ▸ a0_tp) theorem comp_mkId {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (σA) (eq : ym(σ) ≫ A = σA) - (a0 a1 : y(Γ) ⟶ s[i].Tm) + (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) + (a0 a1 : (Γ) ⟶ s[i].Tm) (a0_tp : a0 ≫ s[i].tp = A) (a1_tp : a1 ≫ s[i].tp = A) : - ym(σ) ≫ s.mkId ilen A a0 a1 a0_tp a1_tp = - s.mkId ilen σA (ym(σ) ≫ a0) (ym(σ) ≫ a1) + (σ) ≫ s.mkId ilen A a0 a1 a0_tp a1_tp = + s.mkId ilen σA ((σ) ≫ a0) ((σ) ≫ a1) (by simp [eq, a0_tp]) (by simp [eq, a1_tp]) := by simp [mkId, IdIntro.mkId] rw [← Category.assoc]; congr 1 @@ -822,17 +827,17 @@ theorem comp_mkId {Δ Γ : Ctx} (σ : Δ ⟶ Γ) ----------------------- Γ ⊢ᵢ refl(t) : Id(A, t, t) ``` -/ -def mkRefl {Γ : Ctx} (t : y(Γ) ⟶ s[i].Tm) : y(Γ) ⟶ s[i].Tm := +def mkRefl {Γ : Ctx} (t : (Γ) ⟶ s[i].Tm) : (Γ) ⟶ s[i].Tm := (nmII i).mkRefl t theorem comp_mkRefl {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (t : y(Γ) ⟶ s[i].Tm) : - ym(σ) ≫ s.mkRefl ilen t = s.mkRefl ilen (ym(σ) ≫ t) := by + (t : (Γ) ⟶ s[i].Tm) : + (σ) ≫ s.mkRefl ilen t = s.mkRefl ilen ((σ) ≫ t) := by simp [mkRefl, IdIntro.mkRefl] @[simp] -theorem mkRefl_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) - (t : y(Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) : +theorem mkRefl_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) + (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) : s.mkRefl ilen t ≫ s[i].tp = s.mkId ilen A t t t_tp t_tp := (nmII i).mkRefl_tp t @@ -842,20 +847,20 @@ theorem mkRefl_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) ----------------------- Γ ⊢ᵢ idRec(t) : Id(A, t, t) ``` -/ -def mkIdRec {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) - (t : y(Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (B : y(s[i].ext A) ⟶ s[i].Ty) - (B_eq : s.mkId ilen (ym(s[i].disp A) ≫ A) - (ym(s[i].disp A) ≫ t) (s[i].var A) (by> simp [*]) (var_tp ..) = B) - (M : y(s[i].ext B) ⟶ s[j].Ty) - (r : y(Γ) ⟶ s[j].Tm) (r_tp : r ≫ s[j].tp = - ym(substCons _ (s[i].sec A t t_tp) _ (s.mkRefl ilen t) +def mkIdRec {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) + (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) + (B : (s[i].ext A) ⟶ s[i].Ty) + (B_eq : s.mkId ilen ((s[i].disp A) ≫ A) + ((s[i].disp A) ≫ t) (s[i].var A) (by> simp [*]) (var_tp ..) = B) + (M : (s[i].ext B) ⟶ s[j].Ty) + (r : (Γ) ⟶ s[j].Tm) (r_tp : r ≫ s[j].tp = + (substCons _ (s[i].sec A t t_tp) _ (s.mkRefl ilen t) (by> simp [comp_mkId, t_tp, ← B_eq])) ≫ M) - (u : y(Γ) ⟶ s[i].Tm) (u_tp : u ≫ s[i].tp = A) - (h : y(Γ) ⟶ s[i].Tm) (h_tp : h ≫ s[i].tp = s.mkId ilen A t u t_tp u_tp) : - y(Γ) ⟶ s[j].Tm := by + (u : (Γ) ⟶ s[i].Tm) (u_tp : u ≫ s[i].tp = A) + (h : (Γ) ⟶ s[i].Tm) (h_tp : h ≫ s[i].tp = s.mkId ilen A t u t_tp u_tp) : + (Γ) ⟶ s[j].Tm := by refine (nmId i j).toId'.mkJ t - (ym(substWk _ (substWk _ (𝟙 _) _ _ (by simp [t_tp])) _ _ ?_) ≫ M) + ((substWk _ (substWk _ (𝟙 _) _ _ (by simp [t_tp])) _ _ ?_) ≫ M) r ?_ u (t_tp ▸ u_tp) h ?_ · simp [← B_eq, comp_mkId, ← mkId.eq_def]; congr 1 <;> simp [t_tp, substWk] · simp [r_tp]; rw [← Functor.map_comp_assoc]; congr 1 @@ -863,27 +868,27 @@ def mkIdRec {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) · simp [h_tp, mkId, IdIntro.mkId] theorem comp_mkIdRec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : y(Γ) ⟶ s[i].Ty) (σA) (σA_eq : ym(σ) ≫ A = σA) - (t t_tp B B_eq σB) (σB_eq : ym(s[i].substWk σ _ _ σA_eq) ≫ B = σB) - (M) (r : y(Γ) ⟶ (s[j]'jlen).Tm) (r_tp u u_tp h h_tp) : - ym(σ) ≫ s.mkIdRec ilen jlen A t t_tp B B_eq M r r_tp u u_tp h h_tp = - s.mkIdRec ilen jlen σA (ym(σ) ≫ t) (by> simp [t_tp, ← σA_eq]) + (A : (Γ) ⟶ s[i].Ty) (σA) (σA_eq : (σ) ≫ A = σA) + (t t_tp B B_eq σB) (σB_eq : (s[i].substWk σ _ _ σA_eq) ≫ B = σB) + (M) (r : (Γ) ⟶ (s[j]'jlen).Tm) (r_tp u u_tp h h_tp) : + (σ) ≫ s.mkIdRec ilen jlen A t t_tp B B_eq M r r_tp u u_tp h h_tp = + s.mkIdRec ilen jlen σA ((σ) ≫ t) (by> simp [t_tp, ← σA_eq]) σB (by> simp [← σB_eq, ← B_eq] rw [comp_mkId]; congr! 1 · rw [← Functor.map_comp_assoc, ← Functor.map_comp_assoc, substWk_disp] · simp · rw [← Functor.map_comp_assoc, substWk_disp]; simp [σA_eq]) - (ym(s[i].substWk (s[i].substWk σ _ _ σA_eq) _ _ σB_eq) ≫ M) - (ym(σ) ≫ r) (by> + ((s[i].substWk (s[i].substWk σ _ _ σA_eq) _ _ σB_eq) ≫ M) + ((σ) ≫ r) (by> simp [*] simp only [← Functor.map_comp_assoc]; congr! 2 simp [comp_substCons, comp_sec, substWk, comp_mkRefl]) - (ym(σ) ≫ u) (by> simp [*]) - (ym(σ) ≫ h) (by> simp [*, comp_mkId]) := by + ((σ) ≫ u) (by> simp [*]) + ((σ) ≫ h) (by> simp [*, comp_mkId]) := by simp [mkIdRec, Id'.mkJ] - change let σ' := _; _ = ym(σ') ≫ _; intro σ' - refine .trans ?h1 (congr(ym(σ') ≫ $((nmId i j).comp_j σ t (ym(?v) ≫ M) r ?h2)).trans ?h3) + change let σ' := _; _ = (σ') ≫ _; intro σ' + refine .trans ?h1 (congr((σ') ≫ $((nmId i j).comp_j σ t ((?v) ≫ M) r ?h2)).trans ?h3) case v => exact s[i].substWk (s[i].substWk (𝟙 _) _ _ (by simp [t_tp])) _ _ (by simp [← B_eq, comp_mkId, ← mkId.eq_def] @@ -908,16 +913,16 @@ theorem comp_mkIdRec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) · simp [substWk_disp_functor_map, substWk_disp_functor_map_assoc] @[simp] -theorem mkIdRec_tp {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) - (t t_tp B B_eq M) (r : y(Γ) ⟶ s[j].Tm) (r_tp u u_tp h h_tp) : +theorem mkIdRec_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) + (t t_tp B B_eq M) (r : (Γ) ⟶ s[j].Tm) (r_tp u u_tp h h_tp) : s.mkIdRec ilen jlen A t t_tp B B_eq M r r_tp u u_tp h h_tp ≫ s[j].tp = - ym(substCons _ (s[i].sec _ u u_tp) _ h (by> simp [h_tp, comp_mkId, ← B_eq])) ≫ M := by + (substCons _ (s[i].sec _ u u_tp) _ h (by> simp [h_tp, comp_mkId, ← B_eq])) ≫ M := by simp [mkIdRec, Id'.mkJ_tp]; rw [← Functor.map_comp_assoc]; congr 1 apply (s[i].disp_pullback _).hom_ext <;> simp [Id'.endPtSubst, sec, substWk] @[simp] -theorem mkIdRec_mkRefl {Γ : Ctx} (A : y(Γ) ⟶ s[i].Ty) - (t t_tp B B_eq M) (r : y(Γ) ⟶ s[j].Tm) (r_tp) : +theorem mkIdRec_mkRefl {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) + (t t_tp B B_eq M) (r : (Γ) ⟶ s[j].Tm) (r_tp) : s.mkIdRec ilen jlen A t t_tp B B_eq M r r_tp t t_tp (s.mkRefl ilen t) (s.mkRefl_tp ilen _ t t_tp) = r := by simp [mkIdRec, mkRefl, Id'.mkJ_refl] From 9e019babbf1bdc678c91e718c5b1270d216a9ee8 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 26 Sep 2025 10:45:40 -0400 Subject: [PATCH 03/59] refactor: up to GroupoidModel.NaturalModelBase --- HoTTLean/ForMathlib.lean | 24 + HoTTLean/ForMathlib/CategoryTheory/Core.lean | 68 +-- .../CategoryTheory/FreeGroupoid.lean | 213 +++++++++ .../CategoryTheory/Functor/IsPullback.lean | 98 ++++- HoTTLean/ForMathlib/CategoryTheory/Grpd.lean | 104 +++++ .../CategoryTheory/IsIsofibration.lean | 25 ++ .../ForMathlib/CategoryTheory/Polynomial.lean | 5 + .../ForMathlib/CategoryTheory/Quotient.lean | 34 ++ .../Grothendieck/Groupoidal/IsPullback.lean | 8 + HoTTLean/Groupoids/Basic.lean | 262 +++-------- HoTTLean/Groupoids/IsPullback.lean | 346 +++++---------- HoTTLean/Groupoids/NaturalModelBase.lean | 413 ++++++++---------- HoTTLean/Model/UHom.lean | 102 ++--- HoTTLean/Pointed/Basic.lean | 10 +- HoTTLean/Pointed/IsPullback.lean | 6 +- 15 files changed, 949 insertions(+), 769 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/FreeGroupoid.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/Quotient.lean diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index f42ef46e..07f5f108 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -353,6 +353,30 @@ def functorToAsSmallEquiv {D : Type u₁} [Category.{v₁} D] {C : Type u} [Cate left_inv _ := rfl right_inv _ := rfl +section + +variable {D : Type u₁} [Category.{v₁} D] {C : Type u} [Category.{v} C] + {E : Type u₂} [Category.{v₂} E] (A : D ⥤ AsSmall.{w} C) (B : D ⥤ C) + +lemma functorToAsSmallEquiv_apply_comp_left (F : E ⥤ D) : + functorToAsSmallEquiv (F ⋙ A) = F ⋙ functorToAsSmallEquiv A := + rfl + +lemma functorToAsSmallEquiv_symm_apply_comp_left (F : E ⥤ D) : + functorToAsSmallEquiv.symm (F ⋙ B) = F ⋙ functorToAsSmallEquiv.symm B := + rfl + +lemma functorToAsSmallEquiv_apply_comp_right (F : C ⥤ E) : + functorToAsSmallEquiv (A ⋙ AsSmall.down ⋙ F ⋙ AsSmall.up) = functorToAsSmallEquiv A ⋙ F := + rfl + +lemma functorToAsSmallEquiv_symm_apply_comp_right (F : C ⥤ E) : + functorToAsSmallEquiv.symm (B ⋙ F) = + functorToAsSmallEquiv.symm B ⋙ AsSmall.down ⋙ F ⋙ AsSmall.up := + rfl + +end + open ULift instance (C : Type u) [Category.{v} C] : diff --git a/HoTTLean/ForMathlib/CategoryTheory/Core.lean b/HoTTLean/ForMathlib/CategoryTheory/Core.lean index b1ff0c4a..bd136ad0 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Core.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Core.lean @@ -32,15 +32,6 @@ def comp_inclusion_injective {l0 l1 : D ⥤ Core C} (hl : l0 ⋙ inclusion C = l convert Functor.congr_hom hl f simp --- @[simp] --- theorem id_inv (X : Core C) : --- (𝟙 X : X ⟶ X).iso.inv = 𝟙 X.of := by --- simp only [coreCategory_id_iso_inv] - --- @[simp] theorem comp_iso_inv {X Y Z : Core C} (f : X ⟶ Y) (g : Y ⟶ Z) : --- (f ≫ g).iso.inv = g.iso.inv ≫ f.iso.inv := --- rfl - lemma core_comp_inclusion (F : C ⥤ D) : F.core ⋙ inclusion D = inclusion C ⋙ F := rfl @@ -51,8 +42,9 @@ def map : Cat.{v,u} ⥤ Grpd.{v,u} where variable {Γ : Type u} [Groupoid.{v} Γ] -/- A functor from a groupoid into a category is equivalent +/-- A functor from a groupoid into a category is equivalent to a functor from the groupoid into the core -/ +@[simps apply] def functorToCoreEquiv : Γ ⥤ D ≃ Γ ⥤ Core D where toFun := functorToCore invFun := forgetFunctorToCore.obj @@ -62,42 +54,49 @@ def functorToCoreEquiv : Γ ⥤ D ≃ Γ ⥤ Core D where · aesop_cat · aesop_cat -theorem eqToIso_iso_hom {a b : Core C} (h1 : a = b) - (h2 : (inclusion C).obj a = (inclusion C).obj b) : - (eqToHom h1).iso.hom = eqToHom h2 := by - cases h1 - rfl - -section Adjunction - variable {C : Type u₁} [Category.{v₁} C] variable {G : Type u₂} [Groupoid.{v₂} G] variable {G' : Type u₃} [Groupoid.{v₃} G'] variable {C' : Type u₃} [Category.{v₃} C'] -theorem functorToCore_naturality_left - (H : G ⥤ C) (F : G' ⥤ G) : +@[simp] +theorem functorToCore_comp_inclusion (H : G ⥤ C) : + functorToCore H ⋙ inclusion _ = H := rfl + +theorem functorToCore_comp_left (H : G ⥤ C) (F : G' ⥤ G) : functorToCore (F ⋙ H) = F ⋙ functorToCore H := by apply Functor.ext · simp [functorToCore] · intro rfl -theorem functorToCore_naturality_right - (H : G ⥤ C) (F : C ⥤ C') : - functorToCore (H ⋙ F) - = functorToCore H ⋙ F.core := by - fapply Functor.ext - · aesop_cat - · aesop_cat +theorem functorToCore_comp_right (H : G ⥤ C) (F : C ⥤ C') : + functorToCore (H ⋙ F) = functorToCore H ⋙ F.core := by + rfl + +theorem functorToCoreEquiv_symm_apply_comp_left (H : G ⥤ Core C) (F : G' ⥤ G) : + functorToCoreEquiv.symm (F ⋙ H) = F ⋙ functorToCoreEquiv.symm H := + rfl + +theorem functorToCoreEquiv_symm_apply_comp_right (H : G ⥤ Core C) (F : C ⥤ C') : + functorToCoreEquiv.symm (H ⋙ F.core) = functorToCoreEquiv.symm H ⋙ F := + rfl + +theorem eqToIso_iso_hom {a b : Core C} (h1 : a = b) + (h2 : (inclusion C).obj a = (inclusion C).obj b) : + (eqToHom h1).iso.hom = eqToHom h2 := by + cases h1 + rfl + +section Adjunction def adjunction : Grpd.forgetToCat ⊣ Core.map where unit := { app G := Grpd.homOf (Core.functorToCore (Functor.id _)) naturality _ _ F := by simp [Core.map, Grpd.comp_eq_comp, - ← functorToCore_naturality_left, - ← functorToCore_naturality_right, + ← functorToCore_comp_left, + ← functorToCore_comp_right, Functor.id_comp, Functor.comp_id, Grpd.forgetToCat]} counit := {app C := Cat.homOf (Core.inclusion C)} @@ -209,12 +208,15 @@ namespace ULift namespace Core variable {C : Type u} [Category.{v} C] -attribute [local instance] CategoryTheory.uliftCategory -- FIXME could be generalized? -def isoCoreULift : Cat.of (ULift.{w} (Core C)) ≅ Cat.of (Core (ULift.{w} C)) where - hom := Cat.homOf (downFunctor ⋙ upFunctor.core) - inv := Cat.homOf (downFunctor.core ⋙ upFunctor) +-- def isoCoreULift : +-- Cat.of (ULift.{w} (Core C)) ≅ +-- Cat.of (Core (ULift.{w} C)) where +-- hom := Cat.homOf (downFunctor ⋙ upFunctor.core) +-- inv := Cat.homOf (downFunctor.core ⋙ upFunctor) end Core end ULift + +end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/FreeGroupoid.lean b/HoTTLean/ForMathlib/CategoryTheory/FreeGroupoid.lean new file mode 100644 index 00000000..4d58b3c4 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/FreeGroupoid.lean @@ -0,0 +1,213 @@ +/- +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.Groupoid.FreeGroupoid +import HoTTLean.ForMathlib.CategoryTheory.Quotient +import Mathlib.CategoryTheory.Category.Cat.Limit +import Mathlib.CategoryTheory.Category.Grpd +import HoTTLean.ForMathlib.CategoryTheory.Grpd + +/-! +# Free groupoid on a category + +This file defines the free groupoid on a category, the lifting of a functor to its unique +extension as a functor from the free groupoid, and proves uniqueness of this extension. + +## Main results + +Given a type `C` and a category instance on `C`: + +- `CategoryTheory.Category.FreeGroupoid C`: the underlying type of the free groupoid on `C`. +- `CategoryTheory.Category.FreeGroupoid.instGroupoid`: the `Groupoid` instance on `FreeGroupoid C`. +- `CategoryTheory.Category.lift`: the lifting of a functor `C ⥤ G` where `G` is a groupoid, + to a functor `CategoryTheory.Category.FreeGroupoid C ⥤ G`. +- `CategoryTheory.Category.lift_spec` and `CategoryTheory.Category.lift_unique`: + the proofs that, respectively, `CategoryTheory.Category.lift` indeed is a lifting + and is the unique one. + +## Implementation notes + +The free groupoid on a category `C` is first defined by taking the free groupoid `G` +*on the underlying quiver* of `C`. Then the free groupoid on the *category* `C` is defined as +the quotient of `G` by the relation that makes the inclusion prefunctor `C ⥤q G` a functor. + +## TODO + +Place the original definition `CategoryTheory.FreeGroupoid` into the namespace +`Quiver.FreeGroupoid`. + +-/ + +noncomputable section + +namespace CategoryTheory + +universe v u v₁ u₁ v₂ u₂ + +namespace Category + +variable (C : Type u) [Category.{v} C] + +/-- The relation on the free groupoid on the underlying *quiver* of C that +promotes the prefunctor `C ⥤q FreeGroupoid C` into a functor +`C ⥤ Quotient (FreeGroupoid.homRel C)`. -/ +inductive FreeGroupoid.homRel : HomRel (CategoryTheory.FreeGroupoid C) where +| map_id (X : C) : homRel ((Groupoid.Free.of C).map (𝟙 X)) (𝟙 ((Groupoid.Free.of C).obj X)) +| map_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) : homRel ((Groupoid.Free.of C).map (f ≫ g)) + ((Groupoid.Free.of C).map f ≫ (Groupoid.Free.of C).map g) + +/-- The underlying type of the free groupoid on a category, +defined by quotienting the free groupoid on the underlying quiver of `C` +by the relation that promotes the prefunctor `C ⥤q FreeGroupoid C` into a functor +`C ⥤ Quotient (FreeGroupoid.homRel C)`. -/ +protected def FreeGroupoid := Quotient (FreeGroupoid.homRel C) + +variable {C} in +instance [Nonempty C] : Nonempty (Category.FreeGroupoid C) := by + have : Inhabited (CategoryTheory.FreeGroupoid C) := by + inhabit CategoryTheory.FreeGroupoid C + exact ⟨@default (CategoryTheory.FreeGroupoid C) _⟩ + have : Inhabited (Category.FreeGroupoid C) := inferInstanceAs (Inhabited $ Quotient _) + inhabit Category.FreeGroupoid C + exact ⟨@default (Category.FreeGroupoid C) _⟩ + +variable {C} in +instance : Groupoid (Category.FreeGroupoid C) := + Quotient.groupoid (Category.FreeGroupoid.homRel C) + +namespace FreeGroupoid + +@[simp] +lemma of.map_id (X : C) : (Quotient.functor (FreeGroupoid.homRel C)).map ((Groupoid.Free.of C).map (𝟙 X)) = + 𝟙 _:= by + simp [Quotient.sound _ (Category.FreeGroupoid.homRel.map_id X)] + +@[simp] +lemma of.map_comp {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) : + (Quotient.functor (FreeGroupoid.homRel C)).map ((Groupoid.Free.of C).map (f ≫ g)) = + (Quotient.functor (FreeGroupoid.homRel C)).map ((Groupoid.Free.of C).map f) ≫ + (Quotient.functor (FreeGroupoid.homRel C)).map ((Groupoid.Free.of C).map g) := by + simp [Quotient.sound _ (Category.FreeGroupoid.homRel.map_comp f g)] + +/-- The localization map from the category `C` to the groupoid `Category.FreeGroupoid C` -/ +def of : C ⥤ Category.FreeGroupoid C where + __ := Groupoid.Free.of C ⋙q (Quotient.functor (FreeGroupoid.homRel C)).toPrefunctor + map_id X := by simp + map_comp {X Y Z} f g := by simp + +section UniversalProperty + +variable {C} {G : Type u₁} [Groupoid.{v₁} G] + +/-- The lift of a functor from `C` to a groupoid to a functor from +`FreeGroupoid C` to the groupoid -/ +def lift (φ : C ⥤ G) : Category.FreeGroupoid C ⥤ G := + Quotient.lift (FreeGroupoid.homRel C) (Groupoid.Free.lift φ.toPrefunctor) (by + intros X Y f g r + rcases r with X | ⟨ f , g ⟩ + · simpa using Prefunctor.congr_hom (Groupoid.Free.lift_spec φ.toPrefunctor) (𝟙 X) + · have hf := Prefunctor.congr_hom (Groupoid.Free.lift_spec φ.toPrefunctor) f + have hg := Prefunctor.congr_hom (Groupoid.Free.lift_spec φ.toPrefunctor) g + have hfg := Prefunctor.congr_hom (Groupoid.Free.lift_spec φ.toPrefunctor) (f ≫ g) + simp only [Functor.toPrefunctor_obj, Prefunctor.comp_obj, Prefunctor.comp_map, + Functor.toPrefunctor_map, Quiver.homOfEq_rfl, Functor.map_comp] at * + rw [hf, hg, hfg]) + +theorem lift_spec (φ : C ⥤ G) : of C ⋙ lift φ = φ := by + have : Groupoid.Free.of C ⋙q (Quotient.functor (FreeGroupoid.homRel C)).toPrefunctor ⋙q + (lift φ).toPrefunctor = φ.toPrefunctor := by + simp [lift, Quotient.lift_spec, Groupoid.Free.lift_spec] + fapply Functor.ext + · apply Prefunctor.congr_obj this + · intro _ _ + simpa using Prefunctor.congr_hom this + +theorem lift_unique (φ : C ⥤ G) (Φ : Category.FreeGroupoid C ⥤ G) (hΦ : of C ⋙ Φ = φ) : + Φ = lift φ := by + apply Quotient.lift_unique + apply Groupoid.Free.lift_unique + exact congr_arg Functor.toPrefunctor hΦ + +theorem lift_comp {H : Type u₂} [Groupoid.{v₂} H] (φ : C ⥤ G) (ψ : G ⥤ H) : + lift (φ ⋙ ψ) = lift φ ⋙ ψ := by + symm + apply lift_unique + rw [← Functor.assoc, lift_spec] + +end UniversalProperty + +section Functoriality + +variable {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] + {E : Type u₂} [Category.{v₂} E] + +/-- The functor of free groupoid induced by a prefunctor of quivers -/ +def map (φ : C ⥤ D) : Category.FreeGroupoid C ⥤ Category.FreeGroupoid D := + lift (φ ⋙ of D) + +theorem map_id : map (𝟭 C) = 𝟭 (Category.FreeGroupoid C) := by + dsimp only [map]; symm + apply lift_unique; rfl + +theorem map_comp (φ : C ⥤ D) (φ' : D ⥤ E) : map (φ ⋙ φ') = map φ ⋙ map φ' := by + dsimp only [map]; symm + apply lift_unique; rfl + +end Functoriality + +end FreeGroupoid + +end Category + +namespace Grpd + +open Category.FreeGroupoid + +@[simps] +def free : Cat.{u,u} ⥤ Grpd.{u,u} where + obj C := Grpd.of $ Category.FreeGroupoid C + map {C D} F := map F + map_id C := by + simp [Grpd.id_eq_id, ← map_id] + rfl + map_comp F G := by + simp [Grpd.comp_eq_comp, ← map_comp] + rfl + +@[simps] +def freeForgetAdjunction.unit : 𝟭 Cat ⟶ free ⋙ forgetToCat where + app C := Category.FreeGroupoid.of C + naturality C D F := by simp [forgetToCat, Cat.comp_eq_comp, map, lift_spec] + +@[simps] +def freeForgetAdjunction.counit : forgetToCat ⋙ free ⟶ 𝟭 Grpd where + app G := lift (𝟭 G) + naturality G H φ := by + simp [map, Grpd.comp_eq_comp, ← lift_comp, forgetToCat, Functor.id_comp, Functor.assoc, + lift_spec, Functor.comp_id] + +def freeForgetAdjunction : free ⊣ Grpd.forgetToCat where + unit := freeForgetAdjunction.unit + counit := freeForgetAdjunction.counit + left_triangle_components C := by + simp only [Functor.id_obj, free_obj, Functor.comp_obj, freeForgetAdjunction.unit_app, free_map, + map, freeForgetAdjunction.counit_app, coe_of, comp_eq_comp, ← lift_comp] + symm + apply lift_unique + simp [Functor.comp_id, forgetToCat, Functor.assoc, lift_spec, Grpd.id_eq_id] + right_triangle_components G := by + simp [forgetToCat, Cat.comp_eq_comp, lift_spec, Cat.id_eq_id] + +open Limits + +instance : Reflective forgetToCat where + L := free + adj := freeForgetAdjunction + +instance : HasLimits Grpd.{u,u} := hasLimits_of_reflective forgetToCat + +end Grpd +end CategoryTheory +end diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean index 9f133c72..0e7dc475 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean @@ -705,20 +705,58 @@ def ofRight' {north : Algeria ⥤ Egypt} {rth : Libya ⥤ Egypt} (outer : north ⋙ east = west ⋙ so ⋙ uth) (outer_pb : IsPullback north west east (so ⋙ uth)) (esah : rth ⋙ east = sah ⋙ uth) - (esah_pb : IsPullback rth sah east uth) : - IsPullback (esah_pb.lift north (west ⋙ so) outer) west sah so := + (esah_pb : IsPullback rth sah east uth) + (no : Algeria ⥤ Libya := esah_pb.lift north (west ⋙ so) outer) + (no_eq : no = esah_pb.lift north (west ⋙ so) outer) + : + IsPullback no west sah so := + no_eq ▸ IsPullback.ofUniversal (esah_pb.lift north (west ⋙ so) outer) west sah so (esah_pb.fac_right _ _ _) (fun Cn Cw hC => ofRight'.universal outer esah esah_pb outer_pb Cn Cw hC) (fun Cn Cw hC => ofRight'.universal outer esah esah_pb outer_pb Cn Cw hC) - - end ofRight' end north end Paste +section + +variable {Libya Egypt Chad Sudan : Type*} [Category Libya] + [Category Egypt] [Category Chad] [Category Sudan] + (north : Libya ≅≅ Egypt) (west : Libya ⥤ Chad) + (east : Egypt ⥤ Sudan) (south : Chad ≅≅ Sudan) + (comm_sq : north.hom ⋙ east = west ⋙ south.hom) + +def ofHorizIso.lift {C : Type*} [Category C] (Cn : C ⥤ Egypt) : C ⥤ Libya := + Cn ⋙ north.inv + +include comm_sq in +lemma ofHorizIso.inv_comm_sq : east ⋙ south.inv = north.inv ⋙ west := by + rw [Functor.Iso.eq_inv_comp, ← Functor.assoc, Functor.Iso.comp_inv_eq, comm_sq] + +def ofHorizIso.universal {C : Type*} [Category C] (Cn : C ⥤ Egypt) (Cw : C ⥤ Chad) + (hC : Cn ⋙ east = Cw ⋙ south.hom) : + (lift : C ⥤ Libya) ×' lift ⋙ north.hom = Cn ∧ lift ⋙ west = Cw ∧ + ∀ {l0 l1 : C ⥤ Libya}, l0 ⋙ north.hom = l1 ⋙ north.hom → + l0 ⋙ west = l1 ⋙ west → l0 = l1 := + ⟨ofHorizIso.lift north Cn, by simp [lift, Functor.assoc, Functor.comp_id], + calc _ + _ = (Cw ⋙ south.hom) ⋙ south.inv := by + rw [← hC, Functor.assoc, ofHorizIso.inv_comm_sq _ _ _ _ comm_sq, lift, Functor.assoc] + _ = Cw := by + simp [Functor.assoc, Functor.comp_id], + by + intro _ _ h0 _ + simpa [Functor.Iso.cancel_iso_hom_right] using h0 ⟩ + +def ofHorizIso : IsPullback north.hom west east south.hom := + ofUniversal _ _ _ _ comm_sq + (fun Cn Cw hC => ofHorizIso.universal _ _ _ _ comm_sq Cn Cw hC) + (fun Cn Cw hC => ofHorizIso.universal _ _ _ _ comm_sq Cn Cw hC) + +end end IsPullback @@ -759,5 +797,55 @@ def isPullback : IsPullback (homOf north) (homOf west) (homOf east) comm_sq (lift h) (fac_left _) (fac_right _) (uniq _)) end +end Cat + +namespace Grpd + +open Functor Limits + +variable {Libya Egypt Chad Sudan : Type u} [Groupoid.{v} Libya] + [Groupoid.{v} Egypt] [Groupoid.{v} Chad] [Groupoid.{v} Sudan] + {north : Libya ⥤ Egypt} {west : Libya ⥤ Chad} + {east : Egypt ⥤ Sudan} {south : Chad ⥤ Sudan} + (h : Functor.IsPullback north west east south) + (s : Limits.PullbackCone (homOf east) (homOf south)) + +def lift : s.pt ⟶ of Libya := h.lift s.fst s.snd s.condition -end CategoryTheory.Cat +def fac_left : lift h s ≫ (homOf north) = s.fst := + h.fac_left _ _ _ + +def fac_right : lift h s ≫ (homOf west) = s.snd := + h.fac_right _ _ _ + +def uniq (m : s.pt ⟶ of Libya) (hl : m ≫ homOf north = s.fst) + (hr : m ≫ homOf west = s.snd) : m = lift h s := by + apply h.hom_ext + · convert (fac_left h s).symm + · convert (fac_right h s).symm + +def isPullback : IsPullback (homOf north) (homOf west) (homOf east) + (homOf south) := + IsPullback.of_isLimit (PullbackCone.IsLimit.mk + h.comm_sq (lift h) (fac_left _) (fac_right _) (uniq _)) + +end Grpd + +/-- +The following square is a pullback + + AsSmall C ------- ≅ ------> C + | | + | | + AsSmall F F + | | + | | + v v + AsSmall D ------- ≅ -----> D + +-/ +def AsSmall.isPullback {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] (F : C ⥤ D) : + Functor.IsPullback AsSmall.down (AsSmall.down ⋙ F ⋙ AsSmall.up) F AsSmall.down := + Functor.IsPullback.ofHorizIso AsSmall.downIso _ _ AsSmall.downIso rfl + +end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean index e711784c..1189506f 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean @@ -1,4 +1,8 @@ import HoTTLean.ForMathlib +import Mathlib.CategoryTheory.MorphismProperty.LiftingProperty +import Mathlib.CategoryTheory.CodiscreteCategory +import Mathlib.CategoryTheory.Monad.Limits +import Mathlib.CategoryTheory.Category.Cat.Limit universe w v u v₁ u₁ v₂ u₂ v₃ u₃ @@ -121,5 +125,105 @@ theorem eqToHom_hom {C1 C2 : Grpd.{v,u}} {x y: C1} (f : x ⟶ y) (eq : C1 = C2) subst h simp +open MonoidalCategory MorphismProperty + +def Interval : Type u := Codiscrete (ULift Bool) + +instance : Groupoid (Codiscrete Bool) where + inv f := ⟨⟩ + inv_comp := by aesop + comp_inv := by aesop + +namespace IsIsofibration + +def generatingTrivialCofibrationHom : 𝟙_ Grpd ⟶ Grpd.of $ AsSmall $ Codiscrete Bool where + obj X := ⟨⟨.false⟩⟩ + map _ := ⟨⟨⟩⟩ + map_id := by aesop + map_comp := by aesop + +def generatingTrivialCofibration : MorphismProperty Grpd.{u,u} := + ofHoms (fun _ : Unit => generatingTrivialCofibrationHom) + +end IsIsofibration + +def IsIsofibration : MorphismProperty Grpd := + rlp $ IsIsofibration.generatingTrivialCofibration + end Grpd + +end CategoryTheory + +namespace CategoryTheory + +variable {Γ : Type u} [Groupoid Γ] {Δ : Type u₁} [Groupoid.{v₁} Δ] + +@[simps] +def Grpd.functorIsoOfIso {A B : Grpd} (F : A ≅ B) : A ≅≅ B where + hom := F.hom + inv := F.inv + hom_inv_id := F.hom_inv_id + inv_hom_id := F.inv_hom_id + +noncomputable section + +def Grpd.Functor.iso (A : Γ ⥤ Grpd) {x y : Γ} (f : x ⟶ y) : A.obj x ≅≅ A.obj y := + Grpd.functorIsoOfIso (Functor.mapIso A (asIso f)) + +-- Note: this should not be a simp lemma, because we want simp to +-- see the Functor.Iso structure +def Grpd.Functor.iso_hom (A : Γ ⥤ Grpd) {x y : Γ} (f : x ⟶ y) : + (iso A f).hom = A.map f := rfl + +-- Note: this should not be a simp lemma, because we want simp to +-- see the Functor.Iso structure +def Grpd.Functor.iso_inv (A : Γ ⥤ Grpd) {x y : Γ} (f : x ⟶ y) : + (iso A f).inv = A.map (inv f) := rfl + +@[simp] +lemma Grpd.Functor.iso_id (A : Γ ⥤ Grpd) (x : Γ) : Grpd.Functor.iso A (𝟙 x) = + Functor.Iso.refl _ := by + ext + simp [Grpd.id_eq_id, iso] + +@[simp] +lemma Grpd.Functor.iso_comp (A : Γ ⥤ Grpd) {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : + Grpd.Functor.iso A (f ≫ g) = Grpd.Functor.iso A f ≪⋙ Grpd.Functor.iso A g := by + ext + simp [Grpd.comp_eq_comp, iso] + +@[simp] +lemma Grpd.Functor.iso_naturality (A : Γ ⥤ Grpd) (σ : Δ ⥤ Γ) {x y : Δ} (f : x ⟶ y) : + Grpd.Functor.iso (σ ⋙ A) f = Grpd.Functor.iso A (σ.map f) := by + ext + simp [iso] + +lemma Grpd.Functor.hcongr_obj {C C' D D' : Grpd.{v,u}} (hC : C = C') (hD : D = D') + {F : C ⥤ D} {F' : C' ⥤ D'} (hF : F ≍ F') {x} {x'} (hx : x ≍ x') : + HEq (F.obj x) (F'.obj x') := by + subst hC hD hF hx + rfl + +lemma Grpd.whiskerLeft_hcongr_right {C D : Type*} [Category C] [Category D] + {E E' : Grpd.{v,u}} (hE : E ≍ E') (F : C ⥤ D) {G H : D ⥤ E} {G' H' : D ⥤ E'} + (hG : G ≍ G') (hH : H ≍ H') {α : G ⟶ H} {α' : G' ⟶ H'} (hα : α ≍ α') : + Functor.whiskerLeft F α ≍ Functor.whiskerLeft F α' := by + subst hE hG hH hα + rfl + +lemma Grpd.comp_hcongr {C C' D D' E E' : Grpd.{v,u}} (hC : C ≍ C') (hD : D ≍ D') + (hE : E ≍ E') {F : C ⥤ D} {F' : C' ⥤ D'} {G : D ⥤ E} {G' : D' ⥤ E'} + (hF : F ≍ F') (hG : G ≍ G') + : F ⋙ G ≍ F' ⋙ G' := by + subst hC hD hE hF hG + rfl + +lemma Grpd.NatTrans.hext {X X' Y Y' : Grpd.{v,u}} (hX : X = X') (hY : Y = Y') + {F G : X ⥤ Y} {F' G' : X' ⥤ Y'} (hF : F ≍ F') (hG : G ≍ G') + (α : F ⟶ G) (α' : F' ⟶ G') (happ : ∀ x : X, α.app x ≍ α'.app ((eqToHom hX).obj x)) : + α ≍ α' := by + subst hX hY hF hG + aesop_cat + +end end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean new file mode 100644 index 00000000..4d7a07a3 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean @@ -0,0 +1,25 @@ +import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction +import HoTTLean.ForMathlib.CategoryTheory.Grpd +import HoTTLean.ForMathlib.CategoryTheory.FreeGroupoid + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +namespace CategoryTheory +namespace Grpd + +instance : Grpd.IsIsofibration.IsStableUnderBaseChange := by + dsimp [IsIsofibration] + infer_instance + +instance : Grpd.IsIsofibration.HasObjects := by + sorry + +instance : Grpd.IsIsofibration.IsMultiplicative := by + dsimp [IsIsofibration] + infer_instance + +instance : Grpd.IsIsofibration.HasPushforwards Grpd.IsIsofibration := + sorry + +instance : Grpd.IsIsofibration.IsStableUnderPushforward Grpd.IsIsofibration := + sorry diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 20296b08..9fc4971f 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -787,3 +787,8 @@ theorem mk_comp_left {Δ} (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) (σ: Δ ⟶ -- simp only [← Category.assoc]; congr 1; ext <;> simp end Equiv + +instance preservesPullbacks (P : UvPoly R E B) {Pb X Y Z : C} (fst : Pb ⟶ X) (snd : Pb ⟶ Y) + (f : X ⟶ Z) (g : Y ⟶ Z) (h: IsPullback fst snd f g) : + IsPullback (P.functor.map fst) (P.functor.map snd) (P.functor.map f) (P.functor.map g) := + P.functor.map_isPullback h diff --git a/HoTTLean/ForMathlib/CategoryTheory/Quotient.lean b/HoTTLean/ForMathlib/CategoryTheory/Quotient.lean new file mode 100644 index 00000000..d2ab213a --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/Quotient.lean @@ -0,0 +1,34 @@ +import Mathlib.CategoryTheory.Quotient +import Mathlib.CategoryTheory.Groupoid + +universe u v + +noncomputable section +namespace CategoryTheory +namespace Quotient + +section +variable {G : Type u} [Groupoid.{v} G] (r : HomRel G) + +protected def inv {X Y : Quotient r} (f : X ⟶ Y) : Y ⟶ X := + Quot.liftOn f (fun f' => Quot.mk _ (inv f')) (fun _ _ con => by + rcases con with ⟨ _, f, g, _, hfg ⟩ + have := Quot.sound <| CompClosure.intro (inv g) f g (inv f) hfg + simp only [IsIso.hom_inv_id, Category.comp_id, IsIso.inv_hom_id_assoc] at this + simp only [IsIso.inv_comp, Category.assoc] + repeat rw [← comp_mk] + rw [this]) + +@[simp] +theorem inv_mk {X Y : Quotient r} (f : X.as ⟶ Y.as) : + Quotient.inv r (Quot.mk _ f) = Quot.mk _ (inv f) := + rfl + +instance groupoid : Groupoid.{v} (Quotient r) where + inv f := Quotient.inv r f + inv_comp f := Quot.inductionOn f <| by simp [CategoryStruct.comp, CategoryStruct.id] + comp_inv f := Quot.inductionOn f <| by simp [CategoryStruct.comp, CategoryStruct.id] + +end +end Quotient +end CategoryTheory diff --git a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean index bc7ef908..9cd27f1b 100644 --- a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean +++ b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean @@ -97,6 +97,8 @@ def isPullback' : Functor.IsPullback (toPGrpd' A) forget PGrpd.forgetToGrpd A := (Grothendieck.isPullback _) PGrpd.forgetToPCat_forgetToCat PGrpd.isPullback + _ + rfl theorem toPGrpd_eq_toPGrpd' : toPGrpd A = toPGrpd' A := by apply PGrpd.isPullback.lift_uniq @@ -209,6 +211,12 @@ variable {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] ((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 + subst h + simp [map_id_eq, Functor.id_comp] + end end Groupoidal diff --git a/HoTTLean/Groupoids/Basic.lean b/HoTTLean/Groupoids/Basic.lean index e42d1f54..050c6f16 100644 --- a/HoTTLean/Groupoids/Basic.lean +++ b/HoTTLean/Groupoids/Basic.lean @@ -6,6 +6,7 @@ import Mathlib.CategoryTheory.Monoidal.Cartesian.Cat import HoTTLean.ForMathlib.CategoryTheory.Core import HoTTLean.Model.NaturalModel import HoTTLean.Grothendieck.Groupoidal.IsPullback +import HoTTLean.ForMathlib.CategoryTheory.FreeGroupoid /-! Here we construct universes for the groupoid natural model. @@ -60,247 +61,98 @@ the category of {small groupoids - size u objects and size u hom sets} which itself has size u+1 objects (small groupoids) and size u hom sets (functors). - -We want our context category to be a small category so we will use -`AsSmall.{u}` for some large enough `u` -/ -def Ctx := AsSmall.{u} Grpd.{u,u} - -instance : SmallCategory Ctx := - inferInstanceAs (SmallCategory (AsSmall.{u} Grpd.{u,u})) - -namespace Ctx +@[reducible] +def Ctx := Grpd.{u,u} +-- TODO: replace with just Grpd -def equivalence : CategoryTheory.Equivalence Grpd.{u,u} Ctx.{u} where - functor := AsSmall.up - inverse := AsSmall.down - unitIso := eqToIso rfl - counitIso := eqToIso rfl +instance : CartesianMonoidalCategory Ctx := inferInstanceAs (CartesianMonoidalCategory Grpd) -abbrev ofGrpd : Grpd.{u,u} ⥤ Ctx.{u} := equivalence.functor +instance : HasFiniteLimits Ctx := inferInstanceAs (HasFiniteLimits Grpd) -abbrev toGrpd : Ctx.{u} ⥤ Grpd.{u,u} := equivalence.inverse - -def ofGroupoid (Γ : Type u) [Groupoid.{u} Γ] : Ctx.{u} := - ofGrpd.obj (Grpd.of Γ) - -def ofCategory (C : Type (v+1)) [Category.{v} C] : Ctx.{max u (v+1)} := - Ctx.ofGrpd.obj $ Grpd.of (Core (AsSmall C)) +namespace Ctx -def homOfFunctor {C : Type (v+1)} [Category.{v} C] {D : Type (w+1)} [Category.{w} D] - (F : C ⥤ D) : Ctx.ofCategory.{v, max u (v+1) (w+1)} C - ⟶ Ctx.ofCategory.{w, max u (v+1) (w+1)} D := - Ctx.ofGrpd.map $ Grpd.homOf $ Functor.core $ AsSmall.down ⋙ F ⋙ AsSmall.up +def coreAsSmall (C : Type (v+1)) [Category.{v} C] : Ctx.{max u (v+1)} := + Grpd.of (Core (AsSmall C)) -instance : CartesianMonoidalCategory Ctx := equivalence.chosenFiniteProducts +def coreAsSmallFunctor {C : Type (v+1)} [Category.{v} C] {D : Type (w+1)} [Category.{w} D] + (F : C ⥤ D) : coreAsSmall.{v, max u (v+1) (w+1)} C + ⟶ coreAsSmall.{w, max u (v+1) (w+1)} D := + Grpd.homOf $ Functor.core $ AsSmall.down ⋙ F ⋙ AsSmall.up end Ctx -attribute [local instance] uliftCategory - -@[simps] def catLift : Cat.{u,u} ⥤ Cat.{u,u+1} where - obj x := Cat.of (ULift.{u + 1, u} x) - map {x y} f := downFunctor ⋙ f ⋙ upFunctor - -section yonedaCat -variable (C D) [Category.{u} C] [Category.{u} D] - -/-- `yonedaCat` is the following composition - - Cat --- yoneda ---> Psh Cat -- restrict along inclusion --> Psh Ctx - - where Ctx --- inclusion ---> Cat - takes a groupoid and forgets it to a category - (with appropriate universe level adjustments) --/ -def yonedaCat : Cat.{u,u+1} ⥤ Ctx.{u}ᵒᵖ ⥤ Type (u + 1) := - yoneda ⋙ (whiskeringLeft _ _ _).obj - (AsSmall.down ⋙ Grpd.forgetToCat ⋙ catLift).op - -instance yonedaCatPreservesLimits : PreservesLimits yonedaCat := - comp_preservesLimits _ _ - -variable {Γ Δ : Ctx.{u}} {C D : Cat.{u,u+1}} - -def yonedaCatEquivAux : (yonedaCat.obj C).obj (Opposite.op Γ) - ≃ (Ctx.toGrpd.obj Γ) ⥤ C where - toFun := λ A ↦ ULift.upFunctor ⋙ A - invFun := λ A ↦ ULift.downFunctor ⋙ A - left_inv := λ _ ↦ rfl - right_inv := λ _ ↦ rfl - -/- The bijection y(Γ) → [-,C] ≃ Γ ⥤ C -/ -def yonedaCatEquiv : (yoneda.obj Γ ⟶ yonedaCat.obj C) - ≃ Ctx.toGrpd.obj Γ ⥤ C := - yonedaEquiv.trans yonedaCatEquivAux - -lemma yonedaCatEquiv_yonedaEquivSymm {Γ : Ctx} - (A : (yonedaCat.obj C).obj (Opposite.op Γ)) : - yonedaCatEquiv (yonedaEquiv.symm A) = upFunctor ⋙ A := by - congr - -theorem yonedaCatEquiv_naturality_left - (A : yoneda.obj Γ ⟶ yonedaCat.obj C) (σ : Δ ⟶ Γ) : - yonedaCatEquiv (yoneda.map σ ≫ A) = - (Ctx.toGrpd.map σ) ⋙ yonedaCatEquiv A:= by - simp only [yonedaCatEquiv, Equiv.trans_apply, ← yonedaEquiv_naturality] - rfl - -theorem yonedaCatEquiv_naturality_right - (A : yoneda.obj Γ ⟶ yonedaCat.obj D) (U : D ⥤ C) : - yonedaCatEquiv (A ≫ yonedaCat.map U) = yonedaCatEquiv A ⋙ U := rfl - -theorem yonedaCatEquiv_symm_naturality_left - (A : Ctx.toGrpd.obj Γ ⥤ C) (σ : Δ ⟶ Γ) : - yoneda.map σ ≫ yonedaCatEquiv.symm A = - yonedaCatEquiv.symm (Ctx.toGrpd.map σ ⋙ A) := rfl - -theorem yonedaCatEquiv_symm_naturality_right - (A : Ctx.toGrpd.obj Γ ⥤ D) (U : D ⥤ C) : - yonedaCatEquiv.symm (A ⋙ U) = - yonedaCatEquiv.symm A ≫ yonedaCat.map U := rfl - -end yonedaCat - -def Ctx.homGrpdEquivFunctor {Γ : Ctx} {G : Type v} [Groupoid.{v} G] - : (Γ ⟶ Ctx.ofGrpd.obj (Grpd.of G)) - ≃ Ctx.toGrpd.obj Γ ⥤ G where - toFun A := Ctx.toGrpd.map A - invFun A := Ctx.ofGrpd.map A - left_inv _ := rfl - right_inv _ := rfl +open Ctx section -variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {C : Type (v+1)} [Category.{v} C] +variable {Γ Δ : Type u} [Groupoid Γ] [Groupoid Δ] (σ : Δ ⥤ Γ) {C : Type (v+1)} [Category.{v} C] {D : Type (v+1)} [Category.{v} D] -def toCoreAsSmallEquiv : (Γ ⟶ Ctx.ofGrpd.obj (Grpd.of (Core (AsSmall C)))) - ≃ (Ctx.toGrpd.obj Γ ⥤ C) := - Ctx.homGrpdEquivFunctor.trans ( - Core.functorToCoreEquiv.symm.trans functorToAsSmallEquiv) - -theorem toCoreAsSmallEquiv_symm_naturality_left {A : Ctx.toGrpd.obj Γ ⥤ C} : - toCoreAsSmallEquiv.symm (Ctx.toGrpd.map σ ⋙ A) = σ ≫ toCoreAsSmallEquiv.symm A := by - sorry - -theorem toCoreAsSmallEquiv_naturality_left (A : Γ ⟶ Ctx.ofCategory C) : - toCoreAsSmallEquiv (σ ≫ A) = Ctx.toGrpd.map σ ⋙ toCoreAsSmallEquiv A := by - sorry - -/- The bijection y(Γ) → y[-,C] ≃ Γ ⥤ C -/ -def yonedaCategoryEquiv {Γ : Ctx} {C : Type (v+1)} [Category.{v} C] : - (y(Γ) ⟶ y(Ctx.ofCategory C)) - ≃ Ctx.toGrpd.obj Γ ⥤ C := - Yoneda.fullyFaithful.homEquiv.symm.trans toCoreAsSmallEquiv - -theorem yonedaCategoryEquiv_naturality_left (A : y(Γ) ⟶ y(Ctx.ofCategory C)) : - yonedaCategoryEquiv (ym(σ) ≫ A) = Ctx.toGrpd.map σ ⋙ yonedaCategoryEquiv A := - sorry - -theorem yonedaCategoryEquiv_naturality_left' (A : y(Γ) ⟶ y(Ctx.ofCategory C)) - {σ : y(Δ) ⟶ y(Γ)} : yonedaCategoryEquiv (σ ≫ A) = - Ctx.toGrpd.map (Yoneda.fullyFaithful.preimage σ) - ⋙ yonedaCategoryEquiv A := by - have h : σ = ym(Yoneda.fullyFaithful.preimage σ) := by simp - rw [h, yonedaCategoryEquiv_naturality_left] +def toCoreAsSmallEquiv : (Γ ⥤ coreAsSmall C) ≃ Γ ⥤ C := + Core.functorToCoreEquiv.symm.trans functorToAsSmallEquiv + +theorem toCoreAsSmallEquiv_apply_comp_left (A : Γ ⥤ coreAsSmall C) : + toCoreAsSmallEquiv (σ ⋙ A) = σ ⋙ toCoreAsSmallEquiv A := by rfl -theorem yonedaCategoryEquiv_symm_naturality_left {A : Ctx.toGrpd.obj Γ ⥤ C} : - yonedaCategoryEquiv.symm (Ctx.toGrpd.map σ ⋙ A) = ym(σ) ≫ yonedaCategoryEquiv.symm A := by - rw [yonedaCategoryEquiv.symm_apply_eq, yonedaCategoryEquiv_naturality_left, Equiv.apply_symm_apply] +theorem toCoreAsSmallEquiv_apply_comp_right (A : Γ ⥤ coreAsSmall C) (F : C ⥤ D) : + toCoreAsSmallEquiv (A ⋙ coreAsSmallFunctor F) = toCoreAsSmallEquiv A ⋙ F := by + rfl -theorem yonedaCategoryEquiv_naturality_right {D : Type (v+1)} [Category.{v} D] - (A : y(Γ) ⟶ y(Ctx.ofCategory C)) (F : C ⥤ D) : - yonedaCategoryEquiv (A ≫ ym(Ctx.homOfFunctor F)) = yonedaCategoryEquiv A ⋙ F := - sorry +theorem toCoreAsSmallEquiv_symm_apply_comp_left (A : Γ ⥤ C) : + toCoreAsSmallEquiv.symm (σ ⋙ A) = σ ⋙ toCoreAsSmallEquiv.symm A := by + dsimp only [toCoreAsSmallEquiv, Equiv.symm_trans_apply, Equiv.symm_symm, Grpd.comp_eq_comp] + erw [functorToAsSmallEquiv_symm_apply_comp_left, Core.functorToCoreEquiv_apply, + Core.functorToCore_comp_left] + rfl -theorem yonedaCategoryEquiv_symm_naturality_right - {A : Ctx.toGrpd.obj Γ ⥤ C} (F : C ⥤ D): - yonedaCategoryEquiv.symm (A ⋙ F) = - yonedaCategoryEquiv.symm A ≫ ym(Ctx.homOfFunctor F) := by - sorry +theorem toCoreAsSmallEquiv_symm_apply_comp_right (A : Γ ⥤ C) (F : C ⥤ D) : + toCoreAsSmallEquiv.symm (A ⋙ F) = toCoreAsSmallEquiv.symm A ⋙ coreAsSmallFunctor F := by + rfl end -/-- This is a natural isomorphism between functors in the following diagram - Ctx.{u}------ yoneda -----> Psh Ctx - | Λ - | | - | | - inclusion precomposition with inclusion - | | - | | - | | - V | -Cat.{big univ}-- yoneda -----> Psh Cat - --/ -def asSmallUp_comp_yoneda_iso_forgetToCat_comp_catLift_comp_yonedaCat : - (yoneda : Ctx.{u} ⥤ Ctx.{u}ᵒᵖ ⥤ Type (u + 1)) - ≅ AsSmall.down ⋙ Grpd.forgetToCat ⋙ catLift ⋙ yonedaCat where - hom := {app Γ := yonedaEquiv.symm (CategoryStruct.id _)} - inv := { - app Γ := { - app Δ := λ F ↦ - AsSmall.up.map $ ULift.upFunctor ⋙ F ⋙ ULift.downFunctor}} - -/-- `U.{v}` is the object representing the - universe of `v`-small types - i.e. `y(U) = Ty` for the small natural models `smallU`. -/ -def U : Ctx := - Ctx.ofCategory Grpd.{v,v} - -/-- `E.{v}` is the object representing `v`-small terms, - living over `U.{v}` - i.e. `y(E) = Tm` for the small natural models `smallU`. -/ -def E : Ctx := - Ctx.ofCategory PGrpd.{v,v} - - -/-- `π.{v}` is the morphism representing `v`-small `tp`, - for the small natural models `smallU`. -/ -def π : E.{v} ⟶ U.{v} := - Ctx.homOfFunctor PGrpd.forgetToGrpd - namespace U -variable {Γ : Ctx} (A : Γ ⟶ U.{v}) +/-- `Ty.{v}` is the object representing the + universe of `v`-small types. -/ +def Ty : Ctx := coreAsSmall Grpd.{v,v} -def classifier : Ctx.toGrpd.obj Γ ⥤ Grpd.{v,v} := - Ctx.toGrpd.map A ⋙ Core.inclusion (AsSmall Grpd) ⋙ AsSmall.down +/-- `Tm.{v}` is the object representing `v`-small terms, + living over `Ty.{v}`. -/ +def Tm : Ctx := coreAsSmall PGrpd.{v,v} -def ext : Ctx := - Ctx.ofGrpd.obj (Grpd.of (∫ classifier A)) +/-- `tp.{v}` is the morphism representing `v`-small `tp`, + for the universe `U`. -/ +def tp : Tm.{v} ⟶ Ty.{v} := + coreAsSmallFunctor PGrpd.forgetToGrpd -def disp : ext A ⟶ Γ := - Ctx.ofGrpd.map forget +variable {Γ : Ctx} (A : Γ ⟶ Ty.{v}) -def var : ext A ⟶ E.{v} := - toCoreAsSmallEquiv.symm (toPGrpd (classifier A)) +def ext : Ctx := Grpd.of (∫ toCoreAsSmallEquiv A) -section SmallUHom +@[reducible, simp] +def disp : ext A ⟶ Γ := forget -variable {Γ : Ctx} (A : Γ ⟶ U.{v}) +def var : ext A ⟶ Tm.{v} := + toCoreAsSmallEquiv.symm (toPGrpd (toCoreAsSmallEquiv A)) --- TODO rename `U.toU` to `U.liftU` and rename `U.toE` to `U.liftE` -/-- `toU` is the base map between two `v`-small universes - toE - E.{v} --------------> E.{v+1} +/-- `liftTy` is the base map between two `v`-small universes + liftTm + Tm.{v} --------------> Tm.{v+1} | | | | - π | | π + tp | | tp | | v v - U.{v}-------toU-----> U.{v+1} + Ty.{v}----liftTy----> Ty.{v+1} -/ -def toU : U.{v, max u (v+2)} ⟶ U.{v+1, max u (v+2)} := - Ctx.homOfFunctor.{v+1,v} Grpd.asSmallFunctor.{v+1} - -def toE : E.{v, max u (v+2)} ⟶ E.{v+1,max u (v+2)} := - Ctx.homOfFunctor.{v+1,v} PGrpd.asSmallFunctor.{v+1} +def liftTy : Ty.{v, max u (v+2)} ⟶ Ty.{v+1, max u (v+2)} := + coreAsSmallFunctor.{v+1,v} Grpd.asSmallFunctor.{v+1} -end SmallUHom +def liftTm : Tm.{v, max u (v+2)} ⟶ Tm.{v+1,max u (v+2)} := + coreAsSmallFunctor.{v+1,v} PGrpd.asSmallFunctor.{v+1} end U diff --git a/HoTTLean/Groupoids/IsPullback.lean b/HoTTLean/Groupoids/IsPullback.lean index 51c97e2c..09a44f16 100644 --- a/HoTTLean/Groupoids/IsPullback.lean +++ b/HoTTLean/Groupoids/IsPullback.lean @@ -7,44 +7,33 @@ import HoTTLean.Groupoids.Basic /-! Here we construct universes for the groupoid natural model. + +-- TODO: flip all the diagrams in this file -/ universe w v u v₁ u₁ v₂ u₂ v₃ u₃ noncomputable section open CategoryTheory ULift Functor.Groupoidal - Limits NaturalModel + Limits GroupoidModel.Ctx GroupoidModel.U PGrpd namespace GroupoidModel namespace IsPullback -namespace SmallUHom - -variable {Γ : Ctx.{max u (v + 1)}} (A : Γ ⟶ U.{v}) - -def toU'' : AsSmall.{max u (v+2)} Grpd.{v,v} +def liftTy' : AsSmall.{max u (v+2)} Grpd.{v,v} ⥤ AsSmall.{max u (v+2)} Grpd.{v+1,v+1} := AsSmall.down ⋙ Grpd.asSmallFunctor.{v+1} ⋙ AsSmall.up -def toE'' : AsSmall.{max u (v+2)} PGrpd.{v,v} +def liftTm' : AsSmall.{max u (v+2)} PGrpd.{v,v} ⥤ AsSmall.{max u (v+2)} PGrpd.{v+1,v+1} := AsSmall.down ⋙ PGrpd.asSmallFunctor.{v+1} ⋙ AsSmall.up -def π'' : AsSmall.{max u (v+1)} PGrpd.{v,v} +def tp' : AsSmall.{max u (v+1)} PGrpd.{v,v} ⥤ AsSmall.{max u (v+1)} Grpd.{v,v} := AsSmall.down ⋙ PGrpd.forgetToGrpd ⋙ AsSmall.up -theorem toE''_π'' : Cat.homOf toE''.{v,u} ≫ Cat.homOf π''.{v+1, max u (v+2)} = - Cat.homOf π''.{v, max u (v+2)} ≫ Cat.homOf toU''.{v,u} := rfl - --- TODO remove --- def toE''' : AsSmall.{v+1} PGrpd.{v,v} --- ⥤ PGrpd.{v+1,v+1} := --- AsSmall.down ⋙ PGrpd.asSmallFunctor.{v+1} - --- def toU''' : AsSmall.{v+1} Grpd.{v,v} --- ⥤ Grpd.{v+1,v+1} := --- AsSmall.down ⋙ Grpd.asSmallFunctor.{v+1} +theorem liftTm'_tp' : Cat.homOf liftTm'.{v,u} ≫ Cat.homOf tp'.{v+1, max u (v+2)} = + Cat.homOf tp'.{v, max u (v+2)} ≫ Cat.homOf liftTy'.{v,u} := rfl /-- The following square is a meta-theoretic pullback @@ -75,266 +64,153 @@ def isPullback_forgetToGrpd_forgetToGrpd : /-- The following square is a pullback - AsSmall PGrpd.{v} ------- toE'' ------> AsSmall PGrpd.{v+1} + AsSmall PGrpd.{v} ------- liftTm' ------> AsSmall PGrpd.{v+1} | | | | - π'' π'' + tp' tp' | | | | v v - AsSmall Grpd.{v} ------- toU'' -----> AsSmall Grpd.{v+1} + AsSmall Grpd.{v} ------- liftTy' -----> AsSmall Grpd.{v+1} in the category `Cat.{max u (v+2), max u (v+2)}`. Note that these `AsSmall`s are bringing two different sized categories into the same category. -/ -theorem isPullback_π''_π'' : - IsPullback - (Cat.homOf toE''.{v,max u (v+2)}) - (Cat.homOf π''.{_,max u (v+2)}) - (Cat.homOf π''.{v+1,max u (v+2)}) - (Cat.homOf toU''.{v,max u (v+2)}) := - Cat.isPullback rfl $ +def isPullback_liftTm' : Functor.IsPullback + liftTm'.{v,max u (v+2)} + tp'.{_,max u (v+2)} + tp'.{v+1,max u (v+2)} + liftTy'.{v,max u (v+2)} := Functor.IsPullback.ofIso' PGrpd.asSmallFunctor.{v+1} PGrpd.forgetToGrpd.{v} PGrpd.forgetToGrpd.{v+1} Grpd.asSmallFunctor.{v+1} isPullback_forgetToGrpd_forgetToGrpd - toE''.{v,max u (v+2)} π''.{_,max u (v+2)} π''.{v+1,max u (v+2)} toU''.{v,max u (v+2)} + liftTm'.{v,max u (v+2)} tp'.{_,max u (v+2)} tp'.{v+1,max u (v+2)} liftTy'.{v,max u (v+2)} AsSmall.downIso AsSmall.downIso AsSmall.downIso AsSmall.downIso rfl rfl rfl rfl -open U +theorem isPullback_liftTm'_in_Cat : IsPullback + (Cat.homOf liftTm'.{v,max u (v+2)}) + tp'.{_,max u (v+2)} + tp'.{v+1,max u (v+2)} + (Cat.homOf liftTy'.{v,max u (v+2)}) := + Cat.isPullback rfl isPullback_liftTm' /-- The small universes form pullbacks - y(E.{v}) ------------ toE ---------> y(E.{v+1}) + Tm.{v} ------------ liftTm ---------> Tm.{v+1} | | | | - y(π.{v}) y(π.{v+1}) + tp.{v} tp.{v+1} | | v v - y(U.{v}) ------------ toU ---------> y(U.{v+1}) + Ty.{v} ------------ liftTy ---------> Ty.{v+1} -/ -theorem isPullback_yπ_yπ : - IsPullback ym(toE.{v,max u (v+2)}) ym(π.{v, max u (v+2)}) - ym(π.{v+1,max u (v+2)}) ym(toU.{v,max u (v+2)}) := - Functor.map_isPullback yoneda - (Functor.map_isPullback Ctx.ofGrpd - (Functor.map_isPullback Core.map - isPullback_π''_π'')) - -end SmallUHom - -namespace SmallU - -open U PGrpd - -abbrev coreΓ (Γ : Ctx.{max u (v+1)}) : Grpd.{max u (v+1), max u (v+1)} := - Core.map.obj (Cat.of (Ctx.toGrpd.obj Γ)) - -section -variable {Γ : Ctx.{max u (v+1)}} (A : Γ ⟶ U.{v}) - -abbrev ext' : Grpd.{max u (v+1), max u (v+1)}:= - Grpd.of (∫ classifier A) - -abbrev disp' : ext' A ⟶ Ctx.toGrpd.obj Γ := - forget - -abbrev coreExt' : Grpd.{max u (v+1), max u (v+1)}:= - Core.map.obj (Cat.of (∫ classifier A)) - -abbrev coreDisp' : coreExt' A ⟶ coreΓ.{v,u} Γ := - Core.map.map $ Cat.homOf $ forget - -abbrev coreVar' : coreExt' A ⟶ - Core.map.obj.{max u (v+1), max u (v+1)} - (Cat.asSmallFunctor.obj.{max u (v+1),v,v+1} (Cat.of PGrpd.{v,v})) := - Core.map.map $ Cat.homOf (toPGrpd (classifier A) ⋙ AsSmall.up) +theorem liftTm_isPullback : IsPullback liftTm.{v,max u (v+2)} U.tp.{v, max u (v+2)} + U.tp.{v+1, max u (v+2)} liftTy.{v,max u (v+2)} := by + convert Functor.map_isPullback Core.map isPullback_liftTm'_in_Cat.{v,u} -abbrev coreA : coreΓ.{v,max u (v+1)} Γ ⟶ Core.map.obj.{max u (v+1), max u (v+1)} - (Cat.asSmallFunctor.obj.{u,v,v+1} (Cat.of Grpd.{v,v})) := - Core.map.map (Cat.homOf (Ctx.toGrpd.map A ⋙ Core.inclusion (AsSmall Grpd.{v,v}))) +variable {Γ : Ctx} (A : Γ ⥤ Grpd) -def isPullback_disp'_asSmallForgetToGrpd_comm_sq : - Cat.homOf (toPGrpd (classifier A) ⋙ AsSmall.up) - ≫ Cat.homOf (Cat.asSmallFunctor.map (Cat.homOf forgetToGrpd)) - = Cat.homOf (Functor.Grothendieck.forget (classifier A ⋙ Grpd.forgetToCat)) - ≫ Cat.homOf (Ctx.toGrpd.map A ⋙ Core.inclusion (AsSmall Grpd)) := rfl -end - -variable {Γ : Ctx.{max u (v+1)}} (A : Γ ⟶ U.{v, max u (v+1)}) - --- section IsPullback - --- variable {C : Type*} [Category C] (Cn : C ⥤ AsSmall PGrpd) --- (Cw : C ⥤ ↑(Ctx.toGrpd.obj Γ)) --- (hC : Cn ⋙ AsSmall.down ⋙ forgetToGrpd ⋙ AsSmall.up --- = Cw ⋙ Ctx.toGrpd.map A ⋙ Core.inclusion (AsSmall Grpd)) - --- TODO remove --- include hC in --- theorem isPullback_disp'_asSmallForgetToGrpd.universal_aux : --- (Cn ⋙ AsSmall.down) ⋙ forgetToGrpd = Cw ⋙ classifier A := by --- erw [← congrArg (fun x => Functor.comp x AsSmall.down) hC] --- rfl - --- def isPullback_disp'_asSmallForgetToGrpd.universal : (lift : C ⥤ ∫(classifier A)) ×' --- lift ⋙ toPGrpd (classifier A) ⋙ AsSmall.up = Cn ∧ --- lift ⋙ Grothendieck.forget (classifier A ⋙ Grpd.forgetToCat) = Cw ∧ --- ∀ {l0 l1 : C ⥤ ∫(classifier A)}, --- l0 ⋙ toPGrpd (classifier A) ⋙ AsSmall.up = l1 ⋙ toPGrpd (classifier A) ⋙ AsSmall.up --- → l0 ⋙ Grothendieck.forget (classifier A ⋙ Grpd.forgetToCat) --- = l1 ⋙ Grothendieck.forget (classifier A ⋙ Grpd.forgetToCat) --- → l0 = l1 := --- ⟨ (Grothendieck.Groupoidal.isPullback (classifier A)).lift (Cn ⋙ AsSmall.down) --- Cw (universal_aux A Cn Cw hC), --- by rw [← Functor.assoc, (Grothendieck.Groupoidal.isPullback _).fac_left]; rfl, --- (Grothendieck.Groupoidal.isPullback _).fac_right _ _ _, --- fun hn hw => (Grothendieck.Groupoidal.isPullback _).hom_ext --- (congrArg (fun x => Functor.comp x AsSmall.down) hn) hw --- ⟩ - -theorem isPullback_disp'_asSmallForgetToGrpd : - IsPullback - (Cat.homOf (toPGrpd (classifier A) ⋙ AsSmall.up)) - (Cat.homOf (Functor.Grothendieck.forget - (classifier A ⋙ Grpd.forgetToCat))) - (Cat.homOf $ AsSmall.down ⋙ forgetToGrpd ⋙ AsSmall.up) - (Cat.homOf (Ctx.toGrpd.map A ⋙ - Core.inclusion (AsSmall Grpd))) := - Cat.isPullback rfl $ Functor.IsPullback.ofIso' - (toPGrpd (classifier A)) - (Functor.Grothendieck.forget (classifier A ⋙ Grpd.forgetToCat)) - forgetToGrpd - (classifier A) - (Functor.Groupoidal.isPullback (classifier A)) - (toPGrpd (classifier A) ⋙ AsSmall.up) - (Functor.Grothendieck.forget (classifier A ⋙ Grpd.forgetToCat)) - (AsSmall.down ⋙ forgetToGrpd ⋙ AsSmall.up) - (Ctx.toGrpd.map A ⋙ Core.inclusion (AsSmall Grpd)) - (Functor.Iso.refl _) - AsSmall.downIso - (Functor.Iso.refl _) - AsSmall.downIso - rfl - rfl - rfl - rfl +/-- +∫ toCor...iv A ----> PGrpd + | | + | | + | | + V V + Γ ------------> Grpd +-/ +def isPullbackClassifier : + Functor.IsPullback (toPGrpd A) Functor.Groupoidal.forget + forgetToGrpd A := + Functor.Groupoidal.isPullback A -open SmallUHom +/-- + AsSmall PGrpd ----> PGrpd + | | + | | + | | + V V + AsSmall Grpd ------> Grpd +-/ +def isPullbackAsSmall : + Functor.IsPullback AsSmall.down (AsSmall.down ⋙ PGrpd.forgetToGrpd ⋙ AsSmall.up) + PGrpd.forgetToGrpd AsSmall.down := + CategoryTheory.AsSmall.isPullback _ /-- - The following square is a pullback in `Grpd` -Core(U.ext' A) -- U.coreVar' A ---> U' - | | - | | - | | - | | -Core(U.disp' A) π' - | | - | | - V V -Core(Ctx.toGrpd.obj Γ) - coreA A -> E' +∫ toCore...iv A ----> AsSmall PGrpd + | | + | | + | | + V V + Γ ------------> AsSmall Grpd -/ -theorem isPullback_coreDisp'_π' : - IsPullback - (coreVar' A) - (coreDisp' A) - (Grpd.homOf π''.core) - (coreA A) := - Functor.map_isPullback - Core.map (isPullback_disp'_asSmallForgetToGrpd A) +def isPullbackClassifierOfAsSmall : + Functor.IsPullback (functorToAsSmallEquiv.symm (toPGrpd A)) + Functor.Groupoidal.forget (AsSmall.down ⋙ PGrpd.forgetToGrpd ⋙ AsSmall.up) + (functorToAsSmallEquiv.symm A) := + Functor.IsPullback.Paste.ofRight + (by simp [functorToAsSmallEquiv, ← Functor.assoc, ← toPGrpd_forgetToGrpd]; rfl) + (by rfl) isPullbackAsSmall + (isPullbackClassifier A) /-- - The following square is a pullback in `Grpd` - U.ext' A ------- functorToCore ---> Core(U.ext' A) - | | - | | - | | - π' Core(U.disp' A) - | | - | | - V V - Ctx.toGrpd.obj Γ - functorToCore -> Core(Ctx.toGrpd.obj Γ) +coreAsSmall PGrpd ----> AsSmall PGrpd + | | + | | + | | + V V +coreAsSmall Grpd -----> AsSmall Grpd -/ -theorem isPullback_disp'_coreDisp' : - IsPullback - (Grpd.homOf (Core.functorToCore (Functor.id _))) - (disp' A) - (coreDisp' A) - (Grpd.homOf (Core.functorToCore (Functor.id _))) := - IsPullback.of_horiz_isIso ⟨ rfl ⟩ + +def isPullbackCoreAsSmall : + Functor.IsPullback (Core.inclusion _) (Ctx.coreAsSmallFunctor PGrpd.forgetToGrpd) + (AsSmall.down ⋙ PGrpd.forgetToGrpd ⋙ AsSmall.up) (Core.inclusion _) := + Core.isPullback_map'_self _ /-- - The following square is a pullback in `Grpd` - U.ext' A -- U.var' A ---> E' - | | - | | - | | - U.disp' A π' - | | - | | - V V -Ctx.toGrpd.obj Γ ---------> U' - Ctx.toGrpd.map A +∫ toCo...iv A ----> coreAsSmall PGrpd + | | + | | + | | + V V + Γ ------------> coreAsSmall Grpd -/ -theorem isPullback_disp'_π' : - IsPullback - (Grpd.homOf (Core.functorToCore (toPGrpd (classifier A) ⋙ AsSmall.up))) - (disp' A) - (Grpd.homOf π''.core) - (Ctx.toGrpd.map A) := by - convert IsPullback.paste_horiz - (isPullback_disp'_coreDisp' A) (isPullback_coreDisp'_π' A) - convert_to Ctx.toGrpd.map A = - Grpd.homOf (Core.functorToCore (𝟭 Γ.1)) ≫ - Core.map.map (Cat.homOf (Ctx.toGrpd.map A)) - ≫ Core.map.map (Cat.homOf (Core.inclusion (AsSmall Grpd))) - have h := Core.adjunction.unit.naturality (Ctx.toGrpd.map A) - simp only [AsSmall.down_obj, Grpd.forgetToCat, Ctx.equivalence, - Core.adjunction, Functor.comp_map, id_eq, ← Category.assoc, Ctx.toGrpd] at * - rw [← h] - rfl +def isPullbackClassifierOfCoreAsSmall (A : Γ ⟶ Ty) : + Functor.IsPullback (var A) forget tp (toCoreAsSmallEquiv.symm (toCoreAsSmallEquiv A)) := + Functor.IsPullback.Paste.ofRight' (so := toCoreAsSmallEquiv.symm (toCoreAsSmallEquiv A)) + (by + dsimp [functorToAsSmallEquiv] + convert_to (toPGrpd (toCoreAsSmallEquiv A) ⋙ forgetToGrpd) ⋙ AsSmall.up = _ + erw [toPGrpd_forgetToGrpd, Core.functorToCoreEquiv_apply, Core.functorToCore_comp_inclusion, + Functor.assoc]) + (isPullbackClassifierOfAsSmall (toCoreAsSmallEquiv A)) + (by + dsimp [Ctx.coreAsSmallFunctor, Grpd.homOf] + rw [Core.core_comp_inclusion]) + isPullbackCoreAsSmall (var A) + (by + apply (isPullbackCoreAsSmall).lift_uniq + · simp only [U.var, toCoreAsSmallEquiv, Equiv.symm_trans_apply, Equiv.symm_symm] + erw [Core.functorToCoreEquiv_apply, Core.functorToCore_comp_inclusion] + rfl + · rw [U.var, ← toCoreAsSmallEquiv_symm_apply_comp_left, + ← toCoreAsSmallEquiv_symm_apply_comp_right, toPGrpd_forgetToGrpd]) /-- The following square is a pullback in `Ctx` - U.ext A --- U.var A ---> E + Ty.ext A --- Ty.var A ---> Tm | | | | | | - U.disp A π + Ty.disp A tp | | | | V V - Γ --------- A ------> U + Γ --------- A ------> Ty -/ -theorem isPullback_disp_π : - IsPullback - (U.var A) - (U.disp A) - π - A := - Functor.map_isPullback Ctx.ofGrpd (isPullback_disp'_π' A) - -/-- - The following square is a pullback in `Psh Ctx` - y(U.ext A) --- ym(U.var A) ---> y(E) - | | - | | - | | - ym(U.disp A) ym(π) - | | - | | - V V - y(Γ) ------------- ym(A) ----> y(U) --/ -theorem isPullback_yonedaDisp_yonedaπ : - IsPullback - ym(U.var A) - ym(U.disp A) - ym(π) - ym(A) := - Functor.map_isPullback yoneda (isPullback_disp_π A) - -end SmallU +theorem disp_pullback (A : Γ ⟶ Ty) : IsPullback (var A) forget tp A := by + convert Grpd.isPullback (isPullbackClassifierOfCoreAsSmall A) + simp end IsPullback end GroupoidModel diff --git a/HoTTLean/Groupoids/NaturalModelBase.lean b/HoTTLean/Groupoids/NaturalModelBase.lean index ba05d4e1..1e7e344d 100644 --- a/HoTTLean/Groupoids/NaturalModelBase.lean +++ b/HoTTLean/Groupoids/NaturalModelBase.lean @@ -4,6 +4,7 @@ import Mathlib.CategoryTheory.Category.Cat.Limit import HoTTLean.Model.UHom import HoTTLean.Grothendieck.Groupoidal.IsPullback import HoTTLean.Groupoids.IsPullback +import HoTTLean.ForMathlib.CategoryTheory.IsIsofibration /-! Here we construct universes for the groupoid natural model. @@ -12,64 +13,38 @@ Here we construct universes for the groupoid natural model. universe w v u v₁ u₁ v₂ u₂ v₃ u₃ noncomputable section -open CategoryTheory - Limits NaturalModel Universe - GroupoidModel.IsPullback.SmallU - GroupoidModel.IsPullback.SmallUHom - Functor.Groupoidal +open CategoryTheory Limits NaturalModel Universe + Functor.Groupoidal GroupoidModel.Ctx GroupoidModel.U namespace GroupoidModel -section -variable {Γ : Ctx} (A : y(Γ) ⟶ y(U.{v})) - -def smallU.ext : Ctx := - Ctx.ofGrpd.obj (Grpd.of (∫ yonedaCategoryEquiv A)) - -def smallU.disp : smallU.ext.{v} A ⟶ Γ := - Ctx.ofGrpd.map forget +open U -def smallU.var : y(smallU.ext.{v} A) ⟶ y(E.{v}) := - yonedaCategoryEquiv.symm (toPGrpd (yonedaCategoryEquiv A)) - -end - --- TODO link to this in blueprint -/-- The natural model that acts as the classifier of `v`-large terms and types. - Note that `Ty` and `Tm` are representables, - but since representables are `Ctx`-large, - its representable fibers can be larger (in terms of universe levels) than itself. +/-- The universe the classifies `v`-large terms and types. + The π-clan we use is the set of groupoid isofibrations. -/ -@[simps] def smallU : Universe Ctx where - Ty := y(U.{v}) - Tm := y(E) - tp := ym(π) - ext A := smallU.ext A - disp A := smallU.disp A - var A := smallU.var A - disp_pullback A := by - convert isPullback_yonedaDisp_yonedaπ (Yoneda.fullyFaithful.homEquiv.symm A) - simp +@[simps] +def U : Universe Grpd.IsIsofibration where + Ty := Ty.{v} + Tm := Tm.{v} + tp := tp + morphismProperty := sorry + ext A := ext A + disp A := disp A + var A := var A + disp_pullback A := GroupoidModel.IsPullback.disp_pullback A namespace U open MonoidalCategory -def asSmallClosedType' : tensorUnit _ - ⟶ U.{v+1, max u (v+2)} := +def asSmallClosedType : (tensorUnit _ : Ctx) ⟶ Ty.{v+1, max u (v+2)} := toCoreAsSmallEquiv.symm ((Functor.const _).obj (Grpd.of (Core (AsSmall.{v+1} Grpd.{v,v})))) -def asSmallClosedType : y(tensorUnit _) - ⟶ smallU.{v+1, max u (v+2)}.Ty := - ym(U.asSmallClosedType') - -def isoGrpd : Core (AsSmall.{max u (v+2)} Grpd.{v,v}) - ⥤ Grpd.{v,v} := Core.inclusion _ ⋙ AsSmall.down - def isoExtAsSmallClosedTypeHom : Core (AsSmall.{max u (v+2)} Grpd.{v,v}) - ⥤ ∫(classifier (asSmallClosedType'.{v, max u (v + 2)})) where + ⥤ ∫(toCoreAsSmallEquiv (asSmallClosedType.{v, max u (v + 2)})) where obj X := objMk ⟨⟨⟩⟩ ⟨AsSmall.up.obj.{_,_,v+1} (AsSmall.down.obj X.of)⟩ map {X Y} F := homMk (𝟙 _) ⟨{ hom := AsSmall.up.map.{_,_,v+1} (AsSmall.down.map F.iso.hom) @@ -82,7 +57,7 @@ def isoExtAsSmallClosedTypeHom : rfl }⟩ def isoExtAsSmallClosedTypeInv : - ∫(classifier (asSmallClosedType'.{v, max u (v + 2)})) ⥤ + ∫(toCoreAsSmallEquiv (asSmallClosedType.{v, max u (v + 2)})) ⥤ Core (AsSmall.{max u (v+2)} Grpd.{v,v}) where obj X := ⟨AsSmall.up.obj (AsSmall.down.obj.{_,_,v+1} X.fiber.of)⟩ map {X Y} F := ⟨{ @@ -98,190 +73,143 @@ def isoExtAsSmallClosedTypeInv : rfl }⟩ def isoExtAsSmallClosedType : - U.{v,max u (v+2)} - ≅ smallU.{v+1,max u (v+2)}.ext U.asSmallClosedType.{v, max u (v+2)} where - hom := Ctx.ofGrpd.map (Grpd.homOf isoExtAsSmallClosedTypeHom.{v,u}) - inv := Ctx.ofGrpd.map (Grpd.homOf isoExtAsSmallClosedTypeInv.{v,u}) + Ty.{v,max u (v+2)} + ≅ U.{v+1,max u (v+2)}.ext U.asSmallClosedType.{v, max u (v+2)} where + hom := (Grpd.homOf isoExtAsSmallClosedTypeHom.{v,u}) + inv := (Grpd.homOf isoExtAsSmallClosedTypeInv.{v,u}) hom_inv_id := rfl inv_hom_id := rfl end U -def uHomSeqObjs (i : Nat) (h : i < 4) : Universe Ctx.{4} := +def liftSeqObjs (i : Nat) (h : i < 4) : Universe Grpd.IsIsofibration.{4} := match i with - | 0 => smallU.{0,4} - | 1 => smallU.{1,4} - | 2 => smallU.{2,4} - | 3 => smallU.{3,4} + | 0 => U.{0,4} + | 1 => U.{1,4} + | 2 => U.{2,4} + | 3 => U.{3,4} | (n+4) => by omega -def smallUHom : UHom smallU.{v, max u (v+2)} smallU.{v+1, max u (v+2)} := - @UHom.ofTyIsoExt _ _ _ _ _ - { mapTy := ym(U.toU.{v,max u (v+2)}) - mapTm := ym(U.toE) - pb := isPullback_yπ_yπ } - U.asSmallClosedType - (Functor.mapIso yoneda U.isoExtAsSmallClosedType.{v,u}) - -def uHomSeqHomSucc' (i : Nat) (h : i < 3) : - (uHomSeqObjs i (by omega)).UHom (uHomSeqObjs (i + 1) (by omega)) := +-- TODO: rename UHom to Universe.Lift +def lift : UHom U.{v, max u (v+2)} U.{v+1, max u (v+2)} := + @UHom.ofTyIsoExt _ _ _ _ _ _ + { mapTy := U.liftTy.{v,max u (v+2)} + mapTm := U.liftTm + pb := IsPullback.liftTm_isPullback } + asSmallClosedType + isoExtAsSmallClosedType.{v,u} + +def liftSeqHomSucc' (i : Nat) (h : i < 3) : + UHom (liftSeqObjs i (by omega)) (liftSeqObjs (i + 1) (by omega)) := match i with - | 0 => smallUHom.{0,4} - | 1 => smallUHom.{1,4} - | 2 => smallUHom.{2,4} + | 0 => lift.{0,4} + | 1 => lift.{1,4} + | 2 => lift.{2,4} | (n+3) => by omega /-- The groupoid natural model with three nested representable universes within the ambient natural model. -/ -def uHomSeq : Universe.UHomSeq Ctx.{4} where +def liftSeq : UHomSeq Grpd.IsIsofibration.{4} where length := 3 - objs := uHomSeqObjs - homSucc' := uHomSeqHomSucc' + objs := liftSeqObjs + homSucc' := liftSeqHomSucc' -open CategoryTheory Universe Opposite +open CategoryTheory Opposite section -variable {Γ : Ctx} {C : Type (v+1)} [Category.{v} C] {Δ : Ctx} (σ : Δ ⟶ Γ) - -theorem smallU_lift {Γ Δ : Ctx} (A : y(Γ) ⟶ smallU.{v}.Ty) - (fst : y(Δ) ⟶ smallU.{v}.Tm) (snd : Δ ⟶ Γ) - (w : fst ≫ smallU.{v}.tp = ym(snd) ≫ A) : - (smallU.{v}.disp_pullback A).lift fst ym(snd) w = - ym(Ctx.ofGrpd.map ((Functor.Groupoidal.isPullback _).lift - (yonedaCategoryEquiv fst) - (Ctx.toGrpd.map snd) - (by erw [← yonedaCategoryEquiv_naturality_right, w, - yonedaCategoryEquiv_naturality_left]))) := by - apply (smallU.{v}.disp_pullback A).hom_ext - · dsimp only [smallU_var] - erw [← yonedaCategoryEquiv_symm_naturality_left, - (Functor.Groupoidal.isPullback (yonedaCategoryEquiv A)).fac_left, - Equiv.apply_symm_apply] - simp - · simp only [smallU_ext, smallU_Tm, smallU_Ty, smallU_var, Grpd.coe_of, - smallU_disp, - smallU_tp, IsPullback.lift_snd, ← Functor.map_comp, Grpd.comp_eq_comp, - smallU.disp] - erw [(isPullback (yonedaCategoryEquiv A)).fac_right, AsSmall.down_map_up_map] - -def yonedaCategoryEquivPre (A : y(Γ) ⟶ smallU.{v}.Ty) (σA) (eq : ym(σ) ≫ A = σA) : - ∫(yonedaCategoryEquiv σA) ⥤ ∫(yonedaCategoryEquiv A) := - map (eqToHom (by rw [← eq, yonedaCategoryEquiv_naturality_left])) - ⋙ pre (yonedaCategoryEquiv A) (Ctx.toGrpd.map σ) - -namespace Ctx - -@[simp] lemma toGrpd_obj_ofGrpd_obj (x) : toGrpd.obj (ofGrpd.obj x) = x := rfl - -@[simp] lemma ofGrpd_obj_toGrpd_obj (x) : ofGrpd.obj (toGrpd.obj x) = x := rfl - -@[simp] lemma toGrpd_map_ofGrpd_map {x y} (f : x ⟶ y) : toGrpd.map (ofGrpd.map f) = f := rfl - -@[simp] lemma ofGrpd_map_toGrpd_map {x y} (f : x ⟶ y) : ofGrpd.map (toGrpd.map f) = f := rfl - -end Ctx - -namespace Grothendieck.Groupoidal +variable {Γ : Grpd} {C : Type (v+1)} [Category.{v} C] {Δ : Grpd} (σ : Δ ⟶ Γ) -theorem map_eqToHom_toPGrpd {Γ : Type*} [Category Γ] (A A' : Γ ⥤ Grpd) (h : A = A'): - map (eqToHom h) ⋙ toPGrpd A' = toPGrpd A := by - subst h - simp [map_id_eq, Functor.id_comp] - -end Grothendieck.Groupoidal - -theorem smallU_substWk (A : y(Γ) ⟶ smallU.{v}.Ty) (σA eq) : smallU.substWk σ A σA eq = - (Ctx.ofGrpd.map $ Grpd.homOf $ yonedaCategoryEquivPre σ A σA eq) := by - apply Yoneda.fullyFaithful.map_injective - apply (smallU.disp_pullback A).hom_ext - · conv => right; erw [← yonedaCategoryEquiv_symm_naturality_left] - rw [substWk_var, smallU_var, yonedaCategoryEquivPre, Ctx.toGrpd_map_ofGrpd_map, - Functor.assoc, pre_toPGrpd, Grothendieck.Groupoidal.map_eqToHom_toPGrpd] - dsimp only [smallU_Ty, smallU_ext, smallU.var] - · conv => left; rw [← Functor.map_comp, substWk_disp] - simp only [smallU_disp, ← Functor.map_comp, Grpd.homOf, yonedaCategoryEquivPre, - Grpd.comp_eq_comp, Functor.assoc, smallU.disp] - rw [pre_comp_forget, ← Functor.assoc, map_forget] - rfl +namespace U -@[simp] theorem smallU_sec {Γ : Ctx} (α : y(Γ) ⟶ smallU.{v}.Tm) : - smallU.sec _ α rfl = Ctx.ofGrpd.map (sec _ (yonedaCategoryEquiv α) rfl) := by - apply Yoneda.fullyFaithful.map_injective - apply (smallU.disp_pullback _).hom_ext - . erw [Universe.sec_var, smallU_var, ← yonedaCategoryEquiv_symm_naturality_left, - Equiv.eq_symm_apply, Ctx.toGrpd_map_ofGrpd_map, sec_toPGrpd] +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 + apply (U.disp_pullback A).hom_ext + · rw [substWk_var] + simp [var, Grpd.comp_eq_comp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, Functor.assoc, pre_toPGrpd, + map_eqToHom_toPGrpd] + · rw [substWk_disp] + simp [Grpd.comp_eq_comp, Functor.assoc] + erw [pre_comp_forget, ← Functor.assoc, map_forget] + +@[simp] theorem sec_eq {Γ : Ctx} (α : Γ ⟶ U.{v}.Tm) : + U.sec _ α rfl = sec _ (toCoreAsSmallEquiv α) rfl := by + apply (U.disp_pullback _).hom_ext + . erw [Universe.sec_var, U_var, var, Grpd.comp_eq_comp, + ← toCoreAsSmallEquiv_symm_apply_comp_left, Equiv.eq_symm_apply, sec_toPGrpd] rfl - . rw [← Functor.map_comp, sec_disp] - simp only [CategoryTheory.Functor.map_id, smallU_Tm, smallU_Ty, smallU_tp, smallU_ext, - smallU_disp, ← Functor.map_comp] + . rw [sec_disp] rfl -namespace smallU namespace PtpEquiv -variable (AB : y(Γ) ⟶ smallU.{v}.Ptp.obj y(Ctx.ofCategory C)) +variable (AB : Γ ⟶ U.{v}.Ptp.obj (Ctx.coreAsSmall C)) /-- -A map `(AB : y(Γ) ⟶ smallU.{v}.Ptp.obj y(Ctx.ofCategory C))` +A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. `PtpEquiv.fst` is the `A` in this pair. -/ -def fst : Ctx.toGrpd.obj Γ ⥤ Grpd.{v,v} := - yonedaCategoryEquiv (Universe.PtpEquiv.fst smallU AB) +def fst : Γ ⥤ Grpd.{v,v} := + toCoreAsSmallEquiv (Universe.PtpEquiv.fst U AB) /-- -A map `(AB : y(Γ) ⟶ smallU.{v}.Ptp.obj y(Ctx.ofCategory C))` +A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. `PtpEquiv.snd` is the `B` in this pair. -/ def snd : ∫(fst AB) ⥤ C := - yonedaCategoryEquiv (Universe.PtpEquiv.snd smallU AB) + toCoreAsSmallEquiv (Universe.PtpEquiv.snd U AB) -nonrec theorem fst_comp_left : fst (ym(σ) ≫ AB) = Ctx.toGrpd.map σ ⋙ fst AB := by +nonrec theorem fst_comp_left : fst (σ ≫ AB) = σ ⋙ fst AB := by dsimp only [fst] - rw [PtpEquiv.fst_comp_left, ← yonedaCategoryEquiv_naturality_left] + rw [PtpEquiv.fst_comp_left, ← toCoreAsSmallEquiv_apply_comp_left, Grpd.comp_eq_comp] theorem fst_comp_right {D : Type (v + 1)} [Category.{v, v + 1} D] (F : C ⥤ D) : - fst (AB ≫ smallU.Ptp.map ym(Ctx.homOfFunctor F)) = fst (AB) := by + fst (AB ≫ U.Ptp.map (Ctx.coreAsSmallFunctor F)) = fst AB := by dsimp only [fst] rw [Universe.PtpEquiv.fst_comp_right] -nonrec theorem snd_comp_left : snd (ym(σ) ≫ AB) = - map (eqToHom (fst_comp_left σ AB)) ⋙ pre _ (Ctx.toGrpd.map σ) ⋙ snd AB := by +nonrec theorem snd_comp_left : snd (σ ≫ AB) = + map (eqToHom (fst_comp_left σ AB)) ⋙ pre _ σ ⋙ snd AB := by dsimp only [snd] - rw [PtpEquiv.snd_comp_left smallU (snd._proof_1 AB), yonedaCategoryEquiv_naturality_left] - · rw! (castMode := .all) [Universe.PtpEquiv.fst_comp_left] - simp [smallU_substWk, Ctx.equivalence, yonedaCategoryEquivPre, Grpd.homOf] - rfl - · rw [Universe.PtpEquiv.fst_comp_left] + simp only [eqToHom_refl, map_id_eq, Cat.of_α, Functor.simpIdComp] + erw [PtpEquiv.snd_comp_left U (snd._proof_1 AB), toCoreAsSmallEquiv_apply_comp_left] + · rw [substWk_eq] + · congr 1 + simp [fst, map_id_eq] + · rfl + /-- -A map `(AB : y(Γ) ⟶ smallU.{v}.Ptp.obj y(Ctx.ofCategory C))` +A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. `PtpEquiv.mk` constructs such a map `AB` from such a pair `A` and `B`. -/ -def mk (A : Ctx.toGrpd.obj Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : - y(Γ) ⟶ smallU.{v}.Ptp.obj y(Ctx.ofCategory C) := - Universe.PtpEquiv.mk smallU (yonedaCategoryEquiv.symm A) (yonedaCategoryEquiv.symm B) +def mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : + Γ ⟶ U.{v}.Ptp.obj (Ctx.coreAsSmall C) := + Universe.PtpEquiv.mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B) -theorem hext (AB1 AB2 : y(Γ) ⟶ smallU.{v}.Ptp.obj y(U.{v})) (hfst : fst AB1 = fst AB2) +theorem hext (AB1 AB2 : Γ ⟶ U.{v}.Ptp.obj Ty.{v}) (hfst : fst AB1 = fst AB2) (hsnd : HEq (snd AB1) (snd AB2)) : AB1 = AB2 := by - have hfst' : Universe.PtpEquiv.fst smallU AB1 = Universe.PtpEquiv.fst smallU AB2 := by + have hfst' : Universe.PtpEquiv.fst U AB1 = Universe.PtpEquiv.fst U AB2 := by dsimp [fst] at hfst aesop - apply Universe.PtpEquiv.ext smallU (yonedaCategoryEquiv.symm (fst AB2)) ?_ hfst' ?_ - · simpa [fst] - · dsimp [snd] at hsnd - rw! (castMode := .all) [hfst'] at hsnd - simp only [smallU_Ty, eqRec_heq_iff_heq, heq_eq_eq, EmbeddingLike.apply_eq_iff_eq] at hsnd + apply Universe.PtpEquiv.ext U (Universe.PtpEquiv.fst U AB1) ?_ hfst' ?_ + · simp + · dsimp only [snd] at hsnd + apply toCoreAsSmallEquiv.injective + conv => right; rw! (castMode := .all) [hfst'] + simp [← heq_eq_eq] exact hsnd -lemma fst_mk (A : Ctx.toGrpd.obj Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : +lemma fst_mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : fst (mk A B) = A := by simp [fst, mk, Universe.PtpEquiv.fst_mk] @@ -290,147 +218,168 @@ lemma Grpd.eqToHom_comp_heq {A B : Grpd} {C : Type*} [Category C] subst h simp [Grpd.id_eq_id, Functor.id_comp] -lemma snd_mk_heq (A : Ctx.toGrpd.obj Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : - snd (mk A B) ≍ B := by +lemma snd_mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : + snd (mk A B) = map (eqToHom (fst_mk A B)) ⋙ B := by dsimp only [snd, mk] rw! (castMode := .all) [Universe.PtpEquiv.fst_mk, Universe.PtpEquiv.snd_mk] - simp + simp only [U_ext, U_Ty, Equiv.apply_eq_iff_eq_symm_apply, toCoreAsSmallEquiv_symm_apply_comp_left] + simp only [← heq_eq_eq, eqRec_heq_iff_heq, ← eqToHom_eq_homOf_map (fst_mk A B)] + symm + apply Grpd.eqToHom_comp_heq -lemma snd_mk (A : Ctx.toGrpd.obj Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : - snd (mk A B) = map (eqToHom (fst_mk A B)) ⋙ B := by - have : _ = map (eqToHom (fst_mk A B)) := eqToHom_eq_homOf_map (fst_mk A B) - rw [← this] - apply eq_of_heq; apply (snd_mk_heq A B).trans; symm; apply Grpd.eqToHom_comp_heq +lemma snd_mk_heq (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : + snd (mk A B) ≍ B := by + simp [snd_mk, map_eqToHom_comp_heq] end PtpEquiv -def compDom := smallU.{v}.uvPolyTp.compDom smallU.{v}.uvPolyTp +def compDom := U.{v}.uvPolyTp.compDom U.{v}.uvPolyTp -def comp : compDom.{v} ⟶ smallU.{v}.Ptp.obj y(U.{v}) := - (smallU.{v}.uvPolyTp.comp smallU.{v}.uvPolyTp).p +/- +@[simp] +def comp : compDom.{v} ⟶ U.{v}.Ptp.obj Ty.{v} := + U.uvPolyTp.compP U.uvPolyTp namespace compDom -variable (ab : y(Γ) ⟶ compDom.{v}) +variable (ab : (Γ) ⟶ compDom.{v}) /-- Universal property of `compDom`, decomposition (part 1). -A map `ab : y(Γ) ⟶ compDom` is equivalently three functors +A map `ab : (Γ) ⟶ compDom` is equivalently three functors `fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `fst : Γ ⥤ PGrpd` is `(a : A)` in `(a : A) × (b : B a)`. -/ -def fst : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v} := - yonedaCategoryEquiv (Universe.compDomEquiv.fst ab) +def fst : Γ ⥤ PGrpd.{v,v} := + toCoreAsSmallEquiv (Universe.compDomEquiv.fst ab) /-- Universal property of `compDom`, decomposition (part 2). -A map `ab : y(Γ) ⟶ compDom` is equivalently three functors +A map `ab : (Γ) ⟶ compDom` is equivalently three functors `fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `dependent : Γ ⥤ Grpd` is `B : A → Type` in `(a : A) × (b : B a)`. -/ def dependent : ∫(fst ab ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v} := - yonedaCategoryEquiv (Universe.compDomEquiv.dependent ab) + toCoreAsSmallEquiv (Universe.compDomEquiv.dependent ab) /-- Universal property of `compDom`, decomposition (part 3). -A map `ab : y(Γ) ⟶ compDom` is equivalently three functors +A map `ab : (Γ) ⟶ compDom` is equivalently three functors `fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `snd : Γ ⥤ PGrpd` is `(b : B a)` in `(a : A) × (b : B a)`. -/ -def snd : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v} := - yonedaCategoryEquiv (Universe.compDomEquiv.snd ab) +def snd : Γ ⥤ PGrpd.{v,v} := + toCoreAsSmallEquiv (Universe.compDomEquiv.snd ab) /-- Universal property of `compDom`, decomposition (part 4). -A map `ab : y(Γ) ⟶ compDom` is equivalently three functors +A map `ab : (Γ) ⟶ compDom` is equivalently three functors `fst, dependent, snd` such that `snd_forgetToGrpd`. The equation `snd_forgetToGrpd` 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_forgetToGrpd : snd ab ⋙ PGrpd.forgetToGrpd = sec _ (fst ab) rfl ⋙ (dependent ab) := by - erw [← yonedaCategoryEquiv_naturality_right, Universe.compDomEquiv.snd_tp ab, - smallU_sec, yonedaCategoryEquiv_naturality_left] + erw [← toCoreAsSmallEquiv_apply_comp_right, ← Grpd.comp_eq_comp, + Universe.compDomEquiv.snd_tp ab, sec_eq] rfl /-- Universal property of `compDom`, constructing a map into `compDom`. -/ -def mk (α : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v}) (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) - (β : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) - : y(Γ) ⟶ compDom.{v} := - Universe.compDomEquiv.mk (yonedaCategoryEquiv.symm α) rfl - (yonedaCategoryEquiv.symm B) (yonedaCategoryEquiv.symm β) (by - erw [← yonedaCategoryEquiv_symm_naturality_right, h, - ← yonedaCategoryEquiv_symm_naturality_left, smallU_sec] - rfl) +def mk (α : Γ ⥤ PGrpd.{v,v}) (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) + (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) + : (Γ) ⟶ compDom.{v} := + Universe.compDomEquiv.mk (toCoreAsSmallEquiv.symm α) rfl + (toCoreAsSmallEquiv.symm B) (toCoreAsSmallEquiv.symm β) (by + simp only [U_Ty, U_Tm, U_tp, tp, Grpd.comp_eq_comp, U_ext] + erw [← toCoreAsSmallEquiv_symm_apply_comp_right, h, + ← toCoreAsSmallEquiv_symm_apply_comp_left, sec_eq] + rfl + ) theorem fst_forgetToGrpd : fst ab ⋙ PGrpd.forgetToGrpd = - smallU.PtpEquiv.fst (ab ≫ comp.{v}) := by - erw [smallU.PtpEquiv.fst, ← compDomEquiv.fst_tp ab, ← yonedaCategoryEquiv_naturality_right] + U.PtpEquiv.fst (ab ≫ comp.{v}) := by + erw [U.PtpEquiv.fst, ← compDomEquiv.fst_tp ab, ← toCoreAsSmallEquiv_apply_comp_right] rfl theorem dependent_eq : dependent ab = - map (eqToHom (fst_forgetToGrpd ab)) ⋙ smallU.PtpEquiv.snd (ab ≫ comp.{v}) := by - conv => rhs; rw! (castMode := .all) [← fst_forgetToGrpd] - erw [eqToHom_refl, map_id_eq, Functor.id_comp] - simp only [← heq_eq_eq, heq_eqRec_iff_heq, dependent, compDomEquiv.dependent, PtpEquiv.snd, comp] - rw! (castMode := .all) [compDomEquiv.fst_tp] - simp; rfl - -theorem dependent_heq : HEq (dependent ab) (smallU.PtpEquiv.snd (ab ≫ comp.{v})) := by + map (eqToHom (fst_forgetToGrpd ab)) ⋙ U.PtpEquiv.snd (ab ≫ comp.{v}) := by + dsimp only [dependent] + rw! [compDomEquiv.dependent_eq] + rw [Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left, eqToHom_eq_homOf_map, PtpEquiv.snd] + rfl + +theorem dependent_heq : HEq (dependent ab) (U.PtpEquiv.snd (ab ≫ comp.{v})) := by rw [dependent_eq] apply Functor.precomp_heq_of_heq_id · rw [fst_forgetToGrpd] · rw [fst_forgetToGrpd] · apply map_eqToHom_heq_id_cod -theorem fst_naturality : fst (ym(σ) ≫ ab) = Ctx.toGrpd.map σ ⋙ fst ab := by +theorem fst_naturality : fst ((σ) ≫ ab) = σ ⋙ fst ab := by dsimp only [fst] - rw [← Universe.compDomEquiv.comp_fst, yonedaCategoryEquiv_naturality_left] + rw [← Universe.compDomEquiv.comp_fst, Grpd.comp_eq_comp, + toCoreAsSmallEquiv_apply_comp_left] -theorem dependent_naturality : dependent (ym(σ) ≫ ab) = +theorem dependent_naturality : dependent ((σ) ≫ ab) = map (eqToHom (by rw [fst_naturality, Functor.assoc])) - ⋙ pre _ (Ctx.toGrpd.map σ) ⋙ dependent ab := by + ⋙ pre _ σ ⋙ dependent ab := by rw [dependent, dependent, ← Universe.compDomEquiv.comp_dependent (eq1 := rfl) (eq2 := by simp [← compDomEquiv.comp_fst]), - smallU_substWk, yonedaCategoryEquiv_naturality_left, - Ctx.toGrpd_map_ofGrpd_map, yonedaCategoryEquivPre, Grpd.homOf_comp, - Grpd.comp_eq_comp, Grpd.homOf] - simp [Functor.assoc]; rfl + substWk_eq] + rw! [Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left] + rfl -theorem snd_naturality : snd (ym(σ) ≫ ab) = Ctx.toGrpd.map σ ⋙ snd ab := by +theorem snd_naturality : snd (σ ≫ ab) = σ ⋙ snd ab := by dsimp only [snd] - rw [← Universe.compDomEquiv.comp_snd, yonedaCategoryEquiv_naturality_left] + rw [← Universe.compDomEquiv.comp_snd, Grpd.comp_eq_comp, + toCoreAsSmallEquiv_apply_comp_left] /-- First component of the computation rule for `mk`. -/ -theorem fst_mk (α : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v}) - (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v}) +theorem fst_mk (α : Γ ⥤ PGrpd.{v,v}) + (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) : fst (mk α B β h) = α := by simp [fst, mk, Universe.compDomEquiv.fst_mk] /-- Second component of the computation rule for `mk`. -/ -theorem dependent_mk (α : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v}) - (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v}) +theorem dependent_mk (α : Γ ⥤ PGrpd.{v,v}) + (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) : dependent (mk α B β h) = map (eqToHom (by rw [fst_mk])) ⋙ B := by - sorry + dsimp [dependent, mk] + rw [Equiv.apply_eq_iff_eq_symm_apply, toCoreAsSmallEquiv_symm_apply_comp_left] + rw! (castMode := .all) [compDomEquiv.fst_mk, compDomEquiv.dependent_mk] + simp only [U_Tm, U_ext, U_Ty, ← heq_eq_eq, eqRec_heq_iff_heq] + symm + apply map_eqToHom_comp_heq /-- Second component of the computation rule for `mk`. -/ -theorem snd_mk (α : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v}) - (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Ctx.toGrpd.obj Γ ⥤ PGrpd.{v,v}) +theorem snd_mk (α : Γ ⥤ PGrpd.{v,v}) + (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) : snd (mk α B β h) = β := by dsimp [snd, mk] rw [Universe.compDomEquiv.snd_mk] simp -theorem smallU.compDom.hext (ab1 ab2 : y(Γ) ⟶ smallU.compDom.{v}) (hfst : fst ab1 = fst ab2) - (hdependent : HEq (dependent ab1) (dependent ab2)) (hsnd : snd ab1 = snd ab2) : ab1 = ab2 := by - sorry +theorem hext (ab1 ab2 : Γ ⟶ U.compDom.{v}) + (hfst : fst ab1 = fst ab2) (hdependent : HEq (dependent ab1) (dependent ab2)) + (hsnd : snd ab1 = snd ab2) : ab1 = ab2 := by + dsimp only [compDom] at ab1 + have h1 : compDomEquiv.fst ab1 = compDomEquiv.fst ab2 := by + apply toCoreAsSmallEquiv.injective + assumption + fapply compDomEquiv.ext rfl h1 + · dsimp [dependent] at hdependent + apply toCoreAsSmallEquiv.injective + rw! (castMode := .all) [hdependent, h1] + simp [← heq_eq_eq]; rfl + · apply toCoreAsSmallEquiv.injective + assumption end compDom - -end smallU +-/ +end U end end GroupoidModel diff --git a/HoTTLean/Model/UHom.lean b/HoTTLean/Model/UHom.lean index 448c87a7..b3c5adc5 100644 --- a/HoTTLean/Model/UHom.lean +++ b/HoTTLean/Model/UHom.lean @@ -451,7 +451,8 @@ def Pi_pb : CategoryTheory.UvPoly.preservesPullbacks s[max i j].uvPolyTp _ _ _ _ (s.homOfLe j (max i j)).pb have q := IsPullback.paste_horiz pbB (nmPi (max i j)).Pi_pullback - apply CategoryTheory.IsPullback.paste_horiz (p1 s[j].tp).flip q + sorry + -- apply CategoryTheory.IsPullback.paste_horiz (p1.isCartesian s[j].tp).flip q /-- ``` @@ -553,8 +554,8 @@ theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) s.mkApp ilen jlen σA ((s[i].substWk σ A _ eq) ≫ B) ((σ) ≫ f) (by simp [f_tp, comp_mkPi (eq := eq)]) ((σ) ≫ a) (by simp [a_tp, eq]) := by - unfold mkApp; rw [← Functor.map_comp_assoc, - comp_sec (eq := eq), Functor.map_comp_assoc, comp_unLam (eq := eq)] + unfold mkApp; rw [← Category.assoc, + comp_sec (eq := eq), Category.assoc, comp_unLam (eq := eq)] @[simp] theorem mkLam_unLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) @@ -562,9 +563,9 @@ theorem mkLam_unLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j] s.mkLam ilen jlen A (s.unLam ilen jlen A B f f_tp) = f := by let total : (Γ) ⟶ s[i].Ptp.obj s[j].Tm := (s.Pi_pb ilen jlen).lift f (PtpEquiv.mk s[i] A B) f_tp - simp [mkLam, unLam] + simp only [mkLam, unLam] have : PtpEquiv.fst s[i] total = A := by - simp [total, PtpEquiv.fst, UvPoly.Equiv.fst] + simp only [PtpEquiv.fst, UvPoly.Equiv.fst_eq, total] rw [← s[i].uvPolyTp.map_fstProj s[j].tp] slice_lhs 1 2 => apply (s.Pi_pb ilen jlen).lift_snd apply PtpEquiv.fst_mk @@ -625,7 +626,7 @@ theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j] assumption end Pi - +/- /-! ## Sigma -/ /-- The data of `Sig` and `pair` formers at each universe `s[i].tp`. -/ @@ -785,7 +786,7 @@ theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) simp [this] end Sigma - +-/ /-! ## Identity types -/ class IdSeq (s : UHomSeq R) where @@ -858,14 +859,14 @@ def mkIdRec {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (by> simp [comp_mkId, t_tp, ← B_eq])) ≫ M) (u : (Γ) ⟶ s[i].Tm) (u_tp : u ≫ s[i].tp = A) (h : (Γ) ⟶ s[i].Tm) (h_tp : h ≫ s[i].tp = s.mkId ilen A t u t_tp u_tp) : - (Γ) ⟶ s[j].Tm := by - refine (nmId i j).toId'.mkJ t - ((substWk _ (substWk _ (𝟙 _) _ _ (by simp [t_tp])) _ _ ?_) ≫ M) - r ?_ u (t_tp ▸ u_tp) h ?_ - · simp [← B_eq, comp_mkId, ← mkId.eq_def]; congr 1 <;> simp [t_tp, substWk] - · simp [r_tp]; rw [← Functor.map_comp_assoc]; congr 1 - apply (s[i].disp_pullback _).hom_ext <;> simp [IdIntro.reflSubst, mkRefl, substWk, sec] - · simp [h_tp, mkId, IdIntro.mkId] + (Γ) ⟶ s[j].Tm := by sorry + -- refine (nmId i j).toId'.mkJ t + -- ((substWk _ (substWk _ (𝟙 _) _ _ (by simp [t_tp])) _ _ ?_) ≫ M) + -- r ?_ u (t_tp ▸ u_tp) h ?_ + -- · simp [← B_eq, comp_mkId, ← mkId.eq_def]; congr 1 <;> simp [t_tp, substWk] + -- · simp [r_tp]; rw [← Functor.map_comp_assoc]; congr 1 + -- apply (s[i].disp_pullback _).hom_ext <;> simp [IdIntro.reflSubst, mkRefl, substWk, sec] + -- · simp [h_tp, mkId, IdIntro.mkId] theorem comp_mkIdRec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : (Γ) ⟶ s[i].Ty) (σA) (σA_eq : (σ) ≫ A = σA) @@ -876,55 +877,58 @@ theorem comp_mkIdRec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) σB (by> simp [← σB_eq, ← B_eq] rw [comp_mkId]; congr! 1 - · rw [← Functor.map_comp_assoc, ← Functor.map_comp_assoc, substWk_disp] + · rw [← Category.assoc, ← Category.assoc, substWk_disp] · simp - · rw [← Functor.map_comp_assoc, substWk_disp]; simp [σA_eq]) + · rw [← Category.assoc, substWk_disp]; simp [σA_eq]) ((s[i].substWk (s[i].substWk σ _ _ σA_eq) _ _ σB_eq) ≫ M) ((σ) ≫ r) (by> - simp [*] - simp only [← Functor.map_comp_assoc]; congr! 2 - simp [comp_substCons, comp_sec, substWk, comp_mkRefl]) + -- simp [*] + -- simp only [← Category.assoc]; congr! 2 + -- simp [comp_substCons, comp_sec, substWk, comp_mkRefl] + sorry) ((σ) ≫ u) (by> simp [*]) - ((σ) ≫ h) (by> simp [*, comp_mkId]) := by - simp [mkIdRec, Id'.mkJ] - change let σ' := _; _ = (σ') ≫ _; intro σ' - refine .trans ?h1 (congr((σ') ≫ $((nmId i j).comp_j σ t ((?v) ≫ M) r ?h2)).trans ?h3) - case v => - exact s[i].substWk (s[i].substWk (𝟙 _) _ _ (by simp [t_tp])) _ _ (by - simp [← B_eq, comp_mkId, ← mkId.eq_def] - congr! 1 <;> - · subst t_tp; rw [substWk_disp_functor_map_assoc]; simp) - · simp [← Category.assoc]; congr 1 - apply (s[i].disp_pullback _).hom_ext <;> simp [IdIntro.motiveSubst] - · dsimp [Id'.endPtSubst, σ'] - simp only [substCons_var] - · rw [substWk_disp_functor_map] - apply (s[i].disp_pullback _).hom_ext <;> simp [Id'.endPtSubst, σ', substWk_disp_functor_map] - · simp [r_tp] - simp [← Category.assoc]; congr 1 - apply (s[i].disp_pullback _).hom_ext <;> simp [IdIntro.reflSubst]; rfl - rw [substWk_disp_functor_map, substCons_disp_functor_map_assoc] - apply (s[i].disp_pullback _).hom_ext <;> simp - simp [substWk_disp_functor_map] - · congr 2; simp only [← Category.assoc]; congr 1 - apply (s[i].disp_pullback _).hom_ext <;> simp [IdIntro.motiveSubst] - apply (s[i].disp_pullback _).hom_ext <;> simp - · simp [substWk_disp_functor_map_assoc] - · simp [substWk_disp_functor_map, substWk_disp_functor_map_assoc] + ((σ) ≫ h) (by> simp [*, comp_mkId]) := by sorry + -- simp [mkIdRec, Id'.mkJ] + -- change let σ' := _; _ = (σ') ≫ _; intro σ' + -- refine .trans ?h1 (congr((σ') ≫ $((nmId i j).comp_j σ t ((?v) ≫ M) r ?h2)).trans ?h3) + -- case v => + -- exact s[i].substWk (s[i].substWk (𝟙 _) _ _ (by simp [t_tp])) _ _ (by + -- simp [← B_eq, comp_mkId, ← mkId.eq_def] + -- congr! 1 <;> + -- · subst t_tp; rw [substWk_disp_functor_map_assoc]; simp) + -- · simp [← Category.assoc]; congr 1 + -- apply (s[i].disp_pullback _).hom_ext <;> simp [IdIntro.motiveSubst] + -- · dsimp [Id'.endPtSubst, σ'] + -- simp only [substCons_var] + -- · rw [substWk_disp_functor_map] + -- apply (s[i].disp_pullback _).hom_ext <;> simp [Id'.endPtSubst, σ', substWk_disp_functor_map] + -- · simp [r_tp] + -- simp [← Category.assoc]; congr 1 + -- apply (s[i].disp_pullback _).hom_ext <;> simp [IdIntro.reflSubst]; rfl + -- rw [substWk_disp_functor_map, substCons_disp_functor_map_assoc] + -- apply (s[i].disp_pullback _).hom_ext <;> simp + -- simp [substWk_disp_functor_map] + -- · congr 2; simp only [← Category.assoc]; congr 1 + -- apply (s[i].disp_pullback _).hom_ext <;> simp [IdIntro.motiveSubst] + -- apply (s[i].disp_pullback _).hom_ext <;> simp + -- · simp [substWk_disp_functor_map_assoc] + -- · simp [substWk_disp_functor_map, substWk_disp_functor_map_assoc] @[simp] theorem mkIdRec_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (t t_tp B B_eq M) (r : (Γ) ⟶ s[j].Tm) (r_tp u u_tp h h_tp) : s.mkIdRec ilen jlen A t t_tp B B_eq M r r_tp u u_tp h h_tp ≫ s[j].tp = (substCons _ (s[i].sec _ u u_tp) _ h (by> simp [h_tp, comp_mkId, ← B_eq])) ≫ M := by - simp [mkIdRec, Id'.mkJ_tp]; rw [← Functor.map_comp_assoc]; congr 1 - apply (s[i].disp_pullback _).hom_ext <;> simp [Id'.endPtSubst, sec, substWk] + -- simp [mkIdRec, Id'.mkJ_tp]; rw [← Category.assoc]; congr 1 + -- apply (s[i].disp_pullback _).hom_ext <;> simp [Id'.endPtSubst, sec, substWk] + sorry @[simp] theorem mkIdRec_mkRefl {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (t t_tp B B_eq M) (r : (Γ) ⟶ s[j].Tm) (r_tp) : s.mkIdRec ilen jlen A t t_tp B B_eq M r r_tp t t_tp (s.mkRefl ilen t) (s.mkRefl_tp ilen _ t t_tp) = r := by - simp [mkIdRec, mkRefl, Id'.mkJ_refl] + -- simp [mkIdRec, mkRefl, Id'.mkJ_refl] + sorry end Id diff --git a/HoTTLean/Pointed/Basic.lean b/HoTTLean/Pointed/Basic.lean index e07ac1e1..c4dbb276 100644 --- a/HoTTLean/Pointed/Basic.lean +++ b/HoTTLean/Pointed/Basic.lean @@ -26,7 +26,7 @@ open Grothendieck -- TODO remove this /-- The functor that takes PCat to Cat by forgetting the points-/ abbrev forgetToCat : PCat.{v,u} ⥤ Cat.{v,u} := - Grothendieck.forget _ + Functor.Grothendieck.forget _ -- write using `\d=` prefix:max "⇓" => forgetToCat.obj @@ -129,7 +129,7 @@ end def asSmallFunctor : PCat.{v, u} ⥤ PCat.{max w v u, max w v u} := Grothendieck.functorTo - (Grothendieck.forget _ ⋙ Cat.asSmallFunctor.{w,v,u}) + (Functor.Grothendieck.forget _ ⋙ Cat.asSmallFunctor.{w,v,u}) (fun x => ⟨x.fiber⟩) (fun f => ⟨f.fiber⟩) (fun _ => rfl) @@ -142,7 +142,7 @@ end PCat the underlying `Grothendieck` definitions -/ -abbrev PGrpd := Grothendieck Grpd.forgetToCat.{v,u} +abbrev PGrpd := Functor.Grothendieck Grpd.forgetToCat.{v,u} namespace PGrpd @@ -151,7 +151,7 @@ open Grothendieck Grpd -- TODO remove this /-- The functor that takes PGrpd to Grpd by forgetting the points -/ abbrev forgetToGrpd : PGrpd.{v,u} ⥤ Grpd.{v,u} := - Grothendieck.forget _ + Functor.Grothendieck.forget _ /-- The forgetful functor from PGrpd to PCat -/ def forgetToPCat : PGrpd.{v,u} ⥤ PCat.{v,u} := @@ -409,7 +409,7 @@ def functorTo : Γ ⥤ PGrpd := Grothendieck.functorTo A fibObj fibMap map_id ma variable {A} {fibObj} {fibMap} {map_id} {map_comp} @[simp] theorem functorTo_forget : - functorTo _ _ _ map_id map_comp ⋙ Grothendieck.forget _ = A := + functorTo _ _ _ map_id map_comp ⋙ Functor.Grothendieck.forget _ = A := rfl end diff --git a/HoTTLean/Pointed/IsPullback.lean b/HoTTLean/Pointed/IsPullback.lean index 831d0199..bc889780 100644 --- a/HoTTLean/Pointed/IsPullback.lean +++ b/HoTTLean/Pointed/IsPullback.lean @@ -7,13 +7,9 @@ along `Grpd.forgetToCat` of `PCat.forgetToCat`. ## Main statements -* `CategoryTheory.PGrpd.isPullback_forgetToGrpd_forgetToCat` - +* `CategoryTheory.PGrpd.isPullback` - the functor `PGrpd.forgetToGrpd` is the pullback along `Grpd.forgetToCat` of `PCat.forgetToCat`. - -- TODO Probably the latter half of this file can be shortened - significantly by providing a direct proof of pullback - using the `IsMegaPullback` definitions -/ From a03ab5bcce41768bb66ab6cba196b4f7d77e61e1 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 26 Sep 2025 11:16:33 -0400 Subject: [PATCH 04/59] refactor: up to Groupoids.Id --- HoTTLean/Groupoids/Id.lean | 2 +- HoTTLean/Groupoids/Pi.lean | 83 +---------------------------------- HoTTLean/Groupoids/Sigma.lean | 2 + 3 files changed, 5 insertions(+), 82 deletions(-) diff --git a/HoTTLean/Groupoids/Id.lean b/HoTTLean/Groupoids/Id.lean index 197793bd..2f4a6a4a 100644 --- a/HoTTLean/Groupoids/Id.lean +++ b/HoTTLean/Groupoids/Id.lean @@ -449,7 +449,7 @@ category of contexts -/ - +#exit /- This is the equivelant of Id above -/ diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index 8c07839b..9ac5c0ca 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -41,75 +41,6 @@ lemma Functor.Iso.whiskerLeft_hom_inv {C : Type u} [Category.{v} C] {D : Type u simpa [← heq_eq_eq] using Functor.Iso.whiskerLeft_hom_inv_heq F G H η -variable {Γ : Type u} [Groupoid Γ] {Δ : Type u₁} [Groupoid.{v₁} Δ] - -@[simps] -def Grpd.functorIsoOfIso {A B : Grpd} (F : A ≅ B) : A ≅≅ B where - hom := F.hom - inv := F.inv - hom_inv_id := F.hom_inv_id - inv_hom_id := F.inv_hom_id - -def Grpd.Functor.iso (A : Γ ⥤ Grpd) {x y : Γ} (f : x ⟶ y) : A.obj x ≅≅ A.obj y := - Grpd.functorIsoOfIso (Functor.mapIso A (asIso f)) - --- Note: this should not be a simp lemma, because we want simp to --- see the Functor.Iso structure -def Grpd.Functor.iso_hom (A : Γ ⥤ Grpd) {x y : Γ} (f : x ⟶ y) : - (iso A f).hom = A.map f := rfl - --- Note: this should not be a simp lemma, because we want simp to --- see the Functor.Iso structure -def Grpd.Functor.iso_inv (A : Γ ⥤ Grpd) {x y : Γ} (f : x ⟶ y) : - (iso A f).inv = A.map (inv f) := rfl - -@[simp] -lemma Grpd.Functor.iso_id (A : Γ ⥤ Grpd) (x : Γ) : Grpd.Functor.iso A (𝟙 x) = - Functor.Iso.refl _ := by - ext - simp [Grpd.id_eq_id, iso] - -@[simp] -lemma Grpd.Functor.iso_comp (A : Γ ⥤ Grpd) {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : - Grpd.Functor.iso A (f ≫ g) = Grpd.Functor.iso A f ≪⋙ Grpd.Functor.iso A g := by - ext - simp [Grpd.comp_eq_comp, iso] - -@[simp] -lemma Grpd.Functor.iso_naturality (A : Γ ⥤ Grpd) (σ : Δ ⥤ Γ) {x y : Δ} (f : x ⟶ y) : - Grpd.Functor.iso (σ ⋙ A) f = Grpd.Functor.iso A (σ.map f) := by - ext - simp [iso] - -open Functor - -lemma Grpd.Functor.hcongr_obj {C C' D D' : Grpd.{v,u}} (hC : C = C') (hD : D = D') - {F : C ⥤ D} {F' : C' ⥤ D'} (hF : F ≍ F') {x} {x'} (hx : x ≍ x') : - HEq (F.obj x) (F'.obj x') := by - subst hC hD hF hx - rfl - -lemma Grpd.whiskerLeft_hcongr_right {C D : Type*} [Category C] [Category D] - {E E' : Grpd.{v,u}} (hE : E ≍ E') (F : C ⥤ D) {G H : D ⥤ E} {G' H' : D ⥤ E'} - (hG : G ≍ G') (hH : H ≍ H') {α : G ⟶ H} {α' : G' ⟶ H'} (hα : α ≍ α') : - whiskerLeft F α ≍ whiskerLeft F α' := by - subst hE hG hH hα - rfl - -lemma Grpd.comp_hcongr {C C' D D' E E' : Grpd.{v,u}} (hC : C ≍ C') (hD : D ≍ D') - (hE : E ≍ E') {F : C ⥤ D} {F' : C' ⥤ D'} {G : D ⥤ E} {G' : D' ⥤ E'} - (hF : F ≍ F') (hG : G ≍ G') - : F ⋙ G ≍ F' ⋙ G' := by - subst hC hD hE hF hG - rfl - -lemma Grpd.NatTrans.hext {X X' Y Y' : Grpd.{v,u}} (hX : X = X') (hY : Y = Y') - {F G : X ⥤ Y} {F' G' : X' ⥤ Y'} (hF : F ≍ F') (hG : G ≍ G') - (α : F ⟶ G) (α' : F' ⟶ G') (happ : ∀ x : X, α.app x ≍ α'.app ((eqToHom hX).obj x)) : - α ≍ α' := by - subst hX hY hF hG - aesop_cat - 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 @@ -183,17 +114,6 @@ namespace GroupoidModel open CategoryTheory NaturalModel Universe Opposite Functor.Groupoidal -lemma smallU.PtpEquiv.fst_app_comp_map_tp {Γ : Ctx} (ab : y(Γ) ⟶ smallU.Ptp.obj smallU.Tm) : - smallU.PtpEquiv.fst (ab ≫ smallU.Ptp.map smallU.tp) = smallU.PtpEquiv.fst ab := by - dsimp[fst] - --erw[fst_naturality] - sorry - -lemma smallU.PtpEquiv.snd_app_comp_map_tp {Γ : Ctx} (ab : y(Γ) ⟶ smallU.Ptp.obj smallU.Tm) : - smallU.PtpEquiv.snd (ab ≫ smallU.Ptp.map smallU.tp) - ≍ smallU.PtpEquiv.snd ab ⋙ PGrpd.forgetToGrpd := - sorry - end GroupoidModel end ForOther @@ -952,6 +872,7 @@ end FunctorOperation section variable {Γ : Ctx} +/- namespace smallUPi open FunctorOperation @@ -1098,7 +1019,7 @@ def uHomSeqPis' (i : ℕ) (ilen : i < 4) : instance uHomSeqPi : uHomSeq.PiSeq where nmPi := uHomSeqPis' - +-/ end end GroupoidModel diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index 572c5d5a..20e586e7 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -811,6 +811,7 @@ end sigma end FunctorOperation +/- open FunctorOperation /-- @@ -1006,6 +1007,7 @@ def uHomSeqSigs' (i : ℕ) (ilen : i < 4) : instance uHomSeqSigma : uHomSeq.SigSeq where nmSig := uHomSeqSigs' +-/ end GroupoidModel end From 3a208848d4367361637b5825485adbf1bfcb3d81 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 26 Sep 2025 15:51:29 -0400 Subject: [PATCH 05/59] feat: all UvPoly.Equiv lemmas --- .../ForMathlib/CategoryTheory/Polynomial.lean | 367 +++++++++++------- 1 file changed, 222 insertions(+), 145 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 9fc4971f..c6ff14f8 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -8,6 +8,7 @@ import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction import Mathlib.CategoryTheory.Functor.TwoSquare import Mathlib.CategoryTheory.NatTrans.IsCartesian import Mathlib.CategoryTheory.Comma.Over.Pushforward +import HoTTLean.ForMathlib universe v u v₁ u₁ @@ -23,71 +24,88 @@ namespace MorphismProperty namespace PolynomialPartialAdjunction -variable {T : Type u} [Category.{v} T] {P : MorphismProperty T} - [P.HasPullbacks] [P.IsStableUnderBaseChange] - {Q : MorphismProperty T} [Q.HasPullbacks] [P.HasPushforwards Q] - [P.IsStableUnderPushforward Q] - {S S' S'' : T} (i : S ⟶ S') (q : S ⟶(Q) S'') +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 P ⊤ i ⋙ pushforward P q +abbrev partialRightAdjoint := Over.pullback R ⊤ i ⋙ pushforward R p -abbrev leftAdjoint := CategoryTheory.Over.pullback q.1 ⋙ CategoryTheory.Over.map i +/-- The left adjoint in the partial adjunction. -/ +abbrev leftAdjoint := CategoryTheory.Over.pullback p.1 ⋙ CategoryTheory.Over.map i -/-- `pullback P ⊤ i ⋙ pushforward P q` is a partial right adjoint to -`CategoryTheory.Over.pullback q.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 S''} {Y : P.Over ⊤ S'} : - (X ⟶ ((partialRightAdjoint i q).obj Y).toComma) ≃ - ((leftAdjoint i q).obj X ⟶ Y.toComma) := - calc (X ⟶ ((P.pushforward q).obj ((Over.pullback P ⊤ i).obj Y)).toComma) - _ ≃ ((CategoryTheory.Over.pullback q.1).obj X ⟶ ((Over.pullback P ⊤ i).obj Y).toComma) := +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 q.fst).obj X) ⟶ Y.toComma) := + ((CategoryTheory.Over.pullback p.fst).obj X) ⟶ Y.toComma) := pullback.homEquiv .. -lemma homEquiv_comp {X X' : Over S''} {Y : P.Over ⊤ S'} - (f : X' ⟶ ((partialRightAdjoint i q).obj Y).toComma) (g : X ⟶ X') : - homEquiv i q (g ≫ f) = - (leftAdjoint i q).map g ≫ homEquiv i q f := by +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 S''} {Y Y' : P.Over ⊤ S'} - (f : X ⟶ ((partialRightAdjoint i q).obj Y).toComma) (g : Y ⟶ Y') : - homEquiv i q (f ≫ Comma.Hom.hom ((partialRightAdjoint i q).map g)) = - homEquiv i q f ≫ Comma.Hom.hom g := by +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 S''} {Y Y' : P.Over ⊤ S'} - (f : (leftAdjoint i q).obj X ⟶ Y.toComma) (g : Y ⟶ Y') : - (homEquiv i q).symm f ≫ Comma.Hom.hom ((partialRightAdjoint i q).map g) = - (homEquiv i q).symm (f ≫ Comma.Hom.hom g) := by +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 S''} {Y : P.Over ⊤ S'} - (f : (leftAdjoint i q).obj X' ⟶ Y.toComma) (g : X ⟶ X') : - g ≫ (homEquiv i q).symm f = - (homEquiv i q).symm ((leftAdjoint i q).map g ≫ f) := by +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 q ⋙ Over.forget P ⊤ S'' ⋙ leftAdjoint i q ⟶ Over.forget P ⊤ S' where - app _ := homEquiv i q (𝟙 _) + 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 q).symm.injective + apply (homEquiv i p).symm.injective conv => left; erw [← homEquiv_comp_symm] conv => right; erw [← homEquiv_symm_comp] simp @@ -151,12 +169,14 @@ end MorphismProperty open MorphismProperty.Over -/-- `P : MvPoly R H I O` is a multivariate polynomial functor consisting of the following maps +/-- `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`. @@ -213,18 +233,9 @@ instance {B O : C} (i : B ⟶(R) O) [R.HasPullbacks] [R.IsStableUnderBaseChange] (mapPullbackAdj R ⊤ i.1 i.2 ⟨⟩).isRightAdjoint variable {I O : C} (P : MvPoly R H I O) [R.HasPullbacks] [R.IsStableUnderBaseChange] - [R.IsStableUnderComposition] [H.HasPullbacks] [R.HasPushforwards H] + [H.HasPullbacks] [R.HasPushforwards H] [R.IsStableUnderPushforward H] -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) : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj - -@[inherit_doc] -infix:90 " @ " => apply - open PolynomialPartialAdjunction /-- (Ignoring the indexing from `i` and `o`) @@ -233,20 +244,82 @@ as an object in the `P`-restricted slice over `B`. -/ abbrev fstProj (P : MvPoly R H I O) (X : R.Over ⊤ I) : R.Over ⊤ P.B := (partialRightAdjoint P.i.1 P.p).obj X -@[reassoc (attr := simp)] -lemma map_fstProj (P : MvPoly R H I O) {X Y : R.Over ⊤ I} (f : X ⟶ Y) : - ((partialRightAdjoint P.i.1 P.p).map f).left ≫ (fstProj P Y).hom = (fstProj P X).hom := by - simp - /-- 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) (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) {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) : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj + +@[inherit_doc] +infix:90 " @ " => apply + namespace Equiv variable {P : MvPoly R H I O} {Γ : Over O} {X : R.Over ⊤ I} @@ -364,6 +437,9 @@ instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback A P.p := by convert_to HasPullback A 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 := ⟨terminal.from X, HasObjects.obj_mem _ terminalIsTerminal⟩ @@ -426,6 +502,11 @@ 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 vertical map `ρ : P.p.1 ⟶ Q.p.1` of polynomials (i.e. a commutative triangle) @@ -530,25 +611,39 @@ 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⟩ --- def vertCartExchange - -/-- The composition of morphisms in the category of polynomials. -/ -def comp {E B F D N M : C} {P : UvPoly R E B} {Q : UvPoly R F D} {R : UvPoly R N M} - (f : Hom P Q) (g : Hom Q R) : Hom P R := sorry - end Hom -/-- The domain of the composition of two polynomials. See `UvPoly.comp`. -/ +/-- 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 := - sorry - -- Limits.pullback P'.p (fan P A).snd + 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 +-/ @[simps!] 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 := sorry -- pullback.snd Q.p (fan P A).snd ≫ pullback.fst (fan P A).fst P.p - morphismProperty := sorry - + 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 @@ -556,36 +651,34 @@ variable {P : UvPoly R E B} {Γ X Y : C} /-- Convert the morphism `pair` into a morphism in the over category `Over (⊤_ C)` -/ @[simp] -abbrev fstAux (pair : Γ ⟶ P @ X) : Over.mk (terminal.from Γ) ⟶ +abbrev homMk (pair : Γ ⟶ P @ X) : Over.mk (terminal.from Γ) ⟶ ((toOverTerminal ⋙ MvPoly.functor P.mvPoly).obj X).toComma := Over.homMk pair def fst (pair : Γ ⟶ P @ X) : Γ ⟶ B := - (MvPoly.Equiv.fst (fstAux pair)).hom + (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 (fstAux pair)).left + (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 (fstAux pair)) + 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']; sorry - -- simp lemma in HoTTLean ForMathlib +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.mk (terminal.from (pullback b P.p.1)) ⟶ ((toOverTerminal (R := R)).obj X).toComma := Over.homMk x def mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : Γ ⟶ P @ X := @@ -596,7 +689,7 @@ def mk' (b : Γ ⟶ B) {pb f g} (H : IsPullback (P := pb) f g b P.p) (x : pb ⟶ 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']; sorry + mk b x = mk' b (.of_hasPullback ..) x := by simp [mk'] @[simp] lemma fst_mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : @@ -637,33 +730,34 @@ lemma snd'_eq_snd' (pair : Γ ⟶ P @ X) {pb f g} (H : IsPullback (P := pb) f g ext <;> 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 - sorry - -- have : comparison (c := fan P X) (mk' P X b H x) ≫ _ = - -- (pullback.congrHom (f₁ := mk' P X b H x ≫ _) ..).hom ≫ _ := - -- partialProd.lift_snd ⟨fan P X, isLimitFan P X⟩ b (H.isoPullback.inv ≫ x) - -- have H' : IsPullback (P := R) f g (mk' P X b H x ≫ (fan P X).fst) P.p.1 := by simpa - -- convert congr(H'.isoPullback.hom ≫ $(this)) using 1 - -- · simp [partialProd.snd, partialProd.cone, snd'_eq] - -- simp only [← Category.assoc]; congr! 2 - -- simp [comparison]; ext <;> simp - -- · slice_rhs 1 0 => skip - -- refine .symm <| .trans ?_ (Category.id_comp _); congr! 1 - -- rw [Iso.comp_inv_eq_id]; ext <;> 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 (terminal.from Γ)) + (Over.mk b) (by congr; apply terminal.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 - sorry - -- have h := mk_eq_mk' P X b x - -- set t := mk' P .. - -- have : snd' P X t _ = x := snd'_mk' .. - -- refine .trans ?_ this.heq - -- rw [snd_eq_snd']; congr! 2 <;> simp - -lemma snd_mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : - snd (mk b x) = eqToHom (by simp) ≫ x := by - apply eq_of_heq; rw [heq_eqToHom_comp_iff]; apply snd_mk_heq + simp theorem snd'_comp_left (pair : Γ ⟶ P @ X) {pb f g} (H : IsPullback (P := pb) f g (fst pair) P.p) @@ -681,72 +775,55 @@ 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 - sorry - -- simp [snd'_eq, fan_snd, ε] - -- have := congr($((ExponentiableMorphism.ev P.p.1).naturality ((Over.star E).map f)).left ≫ prod.snd) - -- dsimp at this; simp at this - -- rw [← this]; clear this - -- simp only [← Category.assoc]; congr! 2 - -- ext <;> simp - -- · slice_rhs 2 3 => apply pullback.lift_fst - -- slice_rhs 1 2 => apply pullback.lift_fst - -- simp; rfl - -- · slice_rhs 2 3 => apply pullback.lift_snd - -- symm; apply pullback.lift_snd + 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 - -- rw [snd_eq_snd', snd'_comp_right, snd', Category.assoc, ← eqToIso.hom]; congr! 2 - -- exact IsPullback.isoPullback_eq_eqToIso_left (fst_comp_right _ _ _ f pair) P.p.1 - sorry + 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 (terminal.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 - -- simp [fst_eq] at h1 H - -- apply partialProd.hom_ext ⟨fan P X, isLimitFan P X⟩ h1 - -- refine (cancel_epi H.isoPullback.hom).1 ?_ - -- convert h2 using 1 <;> ( - -- simp [snd'_eq, comparison_pullback.map, partialProd.snd, partialProd.cone] - -- simp only [← Category.assoc]; congr! 2 - -- ext <;> simp) - -- · slice_lhs 2 3 => apply pullback.lift_fst - -- slice_lhs 1 2 => apply H.isoPullback_hom_fst - -- simp - -- · slice_lhs 2 3 => apply pullback.lift_snd - -- slice_lhs 1 2 => apply H.isoPullback_hom_snd - -- simp - sorry + 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' P X (R := R) (f := f) (g := g) (by convert H; simp) - -- · rw [snd'_eq_snd' P X (mk' P X b H' ((IsPullback.isoIsPullback _ _ H H').inv ≫ x)) - -- (by convert H; simp) (by convert H'; simp)] - -- simp [snd'_mk'] - -- · simp - sorry - -@[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 := - .symm <| ext' H (by simp) (by simp) - -@[simp] -lemma eta (pair : Γ ⟶ P @ X) : - mk (fst pair) (snd pair) = pair := by - simp [mk_eq_mk', snd_eq_snd'] + 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 - sorry + 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 From b3598b8cdeb4cc99d0acd32475fe6ef02b71995c Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 27 Sep 2025 13:58:17 -0400 Subject: [PATCH 06/59] feat: UvPoly.compDomEquiv --- .../ForMathlib/CategoryTheory/Polynomial.lean | 201 +++++++++++++++++- 1 file changed, 194 insertions(+), 7 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index c6ff14f8..cc72c242 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -654,6 +654,21 @@ variable {P : UvPoly R E B} {Γ X Y : C} abbrev homMk (pair : Γ ⟶ P @ X) : Over.mk (terminal.from Γ) ⟶ ((toOverTerminal ⋙ MvPoly.functor P.mvPoly).obj X).toComma := Over.homMk pair +/-- +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 @@ -737,15 +752,15 @@ lemma snd_mk (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) : snd (mk 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) : + 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) +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] @@ -865,6 +880,178 @@ theorem mk_comp_left {Δ} (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) (σ: Δ ⟶ 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] + +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_p, 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 ) + +@[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] + +@[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] + +@[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_p] + simp only [hbase', Equiv.snd'_eq, ← Category.assoc] + congr 1 + ext <;> simp [fst]) = 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_p, ← assoc, Equiv.snd'_eq] + congr + 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) + {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 + 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) := From 74acbc917c9e2c9589474728528c596f586be5cc Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 27 Sep 2025 15:36:00 -0400 Subject: [PATCH 07/59] refactor: NaturalModel Sigma --- .../ForMathlib/CategoryTheory/Polynomial.lean | 2 +- HoTTLean/Groupoids/NaturalModelBase.lean | 2 +- HoTTLean/Model/NaturalModel.lean | 150 +++++++++++------- 3 files changed, 96 insertions(+), 58 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index cc72c242..d4a776a7 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -1034,7 +1034,7 @@ lemma dependent_comp {Δ} (σ : Δ ⟶ Γ) (triple : Γ ⟶ compDom P P') congr ext <;> simp -lemma mk_comp {Δ} (σ : Δ ⟶ Γ) (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) +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') : diff --git a/HoTTLean/Groupoids/NaturalModelBase.lean b/HoTTLean/Groupoids/NaturalModelBase.lean index 1e7e344d..a8013c80 100644 --- a/HoTTLean/Groupoids/NaturalModelBase.lean +++ b/HoTTLean/Groupoids/NaturalModelBase.lean @@ -235,7 +235,6 @@ end PtpEquiv def compDom := U.{v}.uvPolyTp.compDom U.{v}.uvPolyTp -/- @[simp] def comp : compDom.{v} ⟶ U.{v}.Ptp.obj Ty.{v} := U.uvPolyTp.compP U.uvPolyTp @@ -271,6 +270,7 @@ is `(b : B a)` in `(a : A) × (b : B a)`. def snd : Γ ⥤ PGrpd.{v,v} := toCoreAsSmallEquiv (Universe.compDomEquiv.snd ab) +/- /-- Universal property of `compDom`, decomposition (part 4). A map `ab : (Γ) ⟶ compDom` is equivalently three functors diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index 3cedc735..8b78bca8 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -345,20 +345,24 @@ theorem PtpEquiv.mk_map {Γ : Ctx} {X Y : Ctx} -- (M.Ptp_equiv AB).2 := -- sorry -/- +abbrev compDom (M N : Universe R) : Ctx := M.uvPolyTp.compDom N.uvPolyTp + +abbrev compP (M N : Universe R) : M.compDom N ⟶ M.uvPolyTp @ N.Ty := + (M.uvPolyTp.comp N.uvPolyTp).p + namespace compDomEquiv open UvPoly variable {M N : Universe 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)`. -/ -def fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ M.Tm := - ab ≫ pullback.snd N.tp (UvPoly.PartialProduct.fan M.uvPolyTp N.Ty).snd ≫ - pullback.snd (M.uvPolyTp.fstProj N.Ty) M.uvPolyTp.p +abbrev fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ M.Tm := + UvPoly.compDomEquiv.fst ab /-- Computation of `comp` (part 1). @@ -373,15 +377,12 @@ def fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ M.Tm := Namely the first projection `α ≫ tp` agrees. -/ theorem fst_tp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : - fst ab ≫ M.tp = PtpEquiv.fst M (ab ≫ (M.uvPolyTp.compP _)) := by - have : pullback.snd (M.uvPolyTp.fstProj N.Ty) M.tp ≫ M.tp = - pullback.fst (M.uvPolyTp.fstProj N.Ty) M.tp ≫ M.uvPolyTp.fstProj N.Ty := - Eq.symm pullback.condition - simp [PtpEquiv.fst, fst, this] - rfl + fst ab ≫ M.tp = PtpEquiv.fst M (ab ≫ M.compP N) := + UvPoly.compDomEquiv.fst_comp_p .. -theorem comp_fst (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : - σ ≫ fst ab = fst (σ ≫ ab) := by simp [fst] +theorem fst_comp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : + fst (σ ≫ ab) = σ ≫ fst ab := + UvPoly.compDomEquiv.fst_comp .. /-- Universal property of `compDom`, decomposition (part 2). @@ -391,17 +392,23 @@ 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) +abbrev 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 := - PtpEquiv.snd M (ab ≫ (M.uvPolyTp.compP _)) _ (by rw [← eq, fst_tp]) + UvPoly.compDomEquiv.dependent ab (M.disp A) (M.var A) <| by + simpa [eq] using (M.disp_pullback A).flip theorem comp_dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) {A} (eq1 : fst ab ≫ M.tp = A) {σA} (eq2 : σ ≫ A = σA) : (substWk M σ _ _ eq2) ≫ dependent ab A eq1 = - dependent (σ ≫ ab) σA (by simp [← comp_fst, eq1, eq2]) := by - rw [dependent, ← PtpEquiv.snd_comp_left]; rfl + 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). @@ -410,11 +417,12 @@ A map `ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp` is equivalently three maps The map `snd : Γ ⟶ M.Tm` is the `(b : B a)` in `(a : A) × (b : B a)`. -/ -def snd (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ N.Tm := - ab ≫ pullback.fst N.tp (PartialProduct.fan M.uvPolyTp N.Ty).snd +abbrev snd (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) : Γ ⟶ N.Tm := + UvPoly.compDomEquiv.snd ab -theorem comp_snd (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : - σ ≫ snd ab = snd (σ ≫ ab) := by simp [snd] +theorem snd_comp (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) (σ : Δ ⟶ Γ) : + snd (σ ≫ ab) = σ ≫ snd ab := + UvPoly.compDomEquiv.snd_comp .. /-- Universal property of `compDom`, decomposition (part 4). @@ -426,21 +434,19 @@ 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) : snd ab ≫ N.tp = (M.sec _ (fst ab) eq) ≫ dependent ab A eq := by - simp [snd, pullback.condition, dependent, PtpEquiv.snd, Equiv.snd'_eq] - simp only [← Category.assoc]; congr! 1 - apply pullback.hom_ext <;> simp [fst, UvPoly.compP] + 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 := by - refine pullback.lift β (pullback.lift (PtpEquiv.mk _ A B) α ?_) ?_ - · simp [← Equiv.fst_eq, ← PtpEquiv.fst.eq_def, eq] - · simp [h] - conv_lhs => arg 2; exact - Equiv.snd'_mk' M.uvPolyTp N.Ty A _ B - |>.symm.trans <| Equiv.snd'_eq M.uvPolyTp N.Ty (PtpEquiv.mk M A B) _ - simp only [← Category.assoc]; congr! 1 - apply pullback.hom_ext <;> simp +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) (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) @@ -452,10 +458,7 @@ theorem dependent_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : dependent (mk α eq B β h) A (by simp [fst_mk, eq]) = B := by - simp [mk, dependent, UvPoly.compP] - convert PtpEquiv.snd_mk M A B using 2 - slice_lhs 1 2 => apply pullback.lift_snd - simp + simp [mk] @[simp] theorem snd_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) @@ -467,12 +470,10 @@ theorem ext {ab₁ ab₂ : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp} (h1 : fst ab₁ = fst ab₂) (h2 : dependent ab₁ A eq = dependent ab₂ A (h1 ▸ eq)) (h3 : snd ab₁ = snd ab₂) : ab₁ = ab₂ := by - refine pullback.hom_ext h3 (pullback.hom_ext ?_ h1) - simp only [dependent, PtpEquiv.snd] at h2 - generalize_proofs _ _ H at h2 - refine Equiv.ext' M.uvPolyTp N.Ty H ?_ h2 - simp [Equiv.fst, pullback.condition] - simp only [← Category.assoc]; congr 1 + 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) @@ -483,9 +484,13 @@ theorem comp_mk σ ≫ mk α e1 B β e2 = mk (σ ≫ α) (by simp [e1, e3]) ((M.substWk σ A _ e3) ≫ B) (σ ≫ β) - (by simp [e2]; rw [← Functor.map_comp_assoc, comp_sec]; simp; congr!) := by - apply ext (A := σA) (by simp [← comp_fst, e1, e3]) <;> simp [← comp_fst, ← comp_snd] - rw [← comp_dependent, dependent_mk] + (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] theorem eta (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) {A} (eq : fst ab ≫ M.tp = A) : @@ -493,19 +498,52 @@ theorem eta (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) symm; apply ext (eq := eq) <;> simp end compDomEquiv --/ + /-! ## Pi and 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 PiAux (U0 U1 U2 : Universe 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 + +/-- The structure on three universes that for +`A : Γ ⟶ U0.Ty` and `B : Γ.A ⟶ U1.Ty` constructs a Π-type `Σ_A B : Γ ⟶ U2.Ty`. -/ +structure SigmaAux (U0 U1 U2 : Universe 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 + set_option linter.dupNamespace false in -protected structure Pi where - Pi : M.Ptp.obj M.Ty ⟶ M.Ty - lam : M.Ptp.obj M.Tm ⟶ M.Tm - Pi_pullback : IsPullback lam (M.Ptp.map M.tp) M.tp Pi - -protected structure Sigma where - Sig : M.Ptp.obj M.Ty ⟶ M.Ty - pair : UvPoly.compDom (uvPolyTp M) (uvPolyTp M) ⟶ M.Tm - -- Sig_pullback : IsPullback pair ((uvPolyTp M).compP (uvPolyTp M)) M.tp Sig +/-- 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 := PiAux M M M + +/-- 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 := SigmaAux M M M /-- Universe.IdIntro consists of the following commutative square From 14fa89d246c445a1fd6a313998417033f4479e89 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 27 Sep 2025 18:51:58 -0400 Subject: [PATCH 08/59] refactor: NaturalModel compDomEquiv --- HoTTLean/Groupoids/NaturalModelBase.lean | 178 ++++++++++++++--------- HoTTLean/Model/NaturalModel.lean | 20 ++- 2 files changed, 121 insertions(+), 77 deletions(-) diff --git a/HoTTLean/Groupoids/NaturalModelBase.lean b/HoTTLean/Groupoids/NaturalModelBase.lean index a8013c80..ac9ce8cf 100644 --- a/HoTTLean/Groupoids/NaturalModelBase.lean +++ b/HoTTLean/Groupoids/NaturalModelBase.lean @@ -136,8 +136,9 @@ theorem substWk_eq (A : Γ ⟶ U.Ty.{v}) (σA : Δ ⟶ U.Ty.{v}) (eq) : simp [Grpd.comp_eq_comp, Functor.assoc] erw [pre_comp_forget, ← Functor.assoc, map_forget] -@[simp] theorem sec_eq {Γ : Ctx} (α : Γ ⟶ U.{v}.Tm) : - U.sec _ α rfl = sec _ (toCoreAsSmallEquiv α) rfl := by +@[simp] theorem sec_eq {Γ : Ctx} (α : Γ ⟶ U.{v}.Tm) (A : Γ ⟶ U.{v}.Ty) (hα : α ≫ U.tp = A) : + U.sec _ α hα = sec (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv α) + (by rw [← hα, Grpd.comp_eq_comp, tp, toCoreAsSmallEquiv_apply_comp_right]) := by apply (U.disp_pullback _).hom_ext . erw [Universe.sec_var, U_var, var, Grpd.comp_eq_comp, ← toCoreAsSmallEquiv_symm_apply_comp_left, Equiv.eq_symm_apply, sec_toPGrpd] @@ -158,14 +159,17 @@ thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. def fst : Γ ⥤ Grpd.{v,v} := toCoreAsSmallEquiv (Universe.PtpEquiv.fst U AB) +variable (A := fst AB) (hA : A = fst AB := by rfl) + /-- A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. `PtpEquiv.snd` is the `B` in this pair. -/ -def snd : ∫(fst AB) ⥤ C := - toCoreAsSmallEquiv (Universe.PtpEquiv.snd U AB) +def snd : ∫A ⥤ C := + toCoreAsSmallEquiv (Universe.PtpEquiv.snd U AB (toCoreAsSmallEquiv.symm A) (by + simp [Universe.PtpEquiv.fst, hA, fst])) nonrec theorem fst_comp_left : fst (σ ≫ AB) = σ ⋙ fst AB := by dsimp only [fst] @@ -176,15 +180,14 @@ theorem fst_comp_right {D : Type (v + 1)} [Category.{v, v + 1} D] (F : C ⥤ D) dsimp only [fst] rw [Universe.PtpEquiv.fst_comp_right] -nonrec theorem snd_comp_left : snd (σ ≫ AB) = - map (eqToHom (fst_comp_left σ AB)) ⋙ pre _ σ ⋙ snd AB := by +nonrec theorem snd_comp_left : snd (σ ≫ AB) (σ ⋙ A) (by rw [hA, fst_comp_left]) = + map (eqToHom (by rw [hA])) ⋙ pre _ σ ⋙ snd AB := by dsimp only [snd] - simp only [eqToHom_refl, map_id_eq, Cat.of_α, Functor.simpIdComp] - erw [PtpEquiv.snd_comp_left U (snd._proof_1 AB), toCoreAsSmallEquiv_apply_comp_left] - · rw [substWk_eq] - · congr 1 - simp [fst, map_id_eq] - · rfl + erw [PtpEquiv.snd_comp_left _ rfl + (by simp [toCoreAsSmallEquiv_symm_apply_comp_left, Grpd.comp_eq_comp, hA, fst]), + toCoreAsSmallEquiv_apply_comp_left] + subst hA + simp [map_id_eq, substWk_eq]; rfl /-- A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` @@ -209,6 +212,7 @@ theorem hext (AB1 AB2 : Γ ⟶ U.{v}.Ptp.obj Ty.{v}) (hfst : fst AB1 = fst AB2) simp [← heq_eq_eq] exact hsnd +@[simp] lemma fst_mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : fst (mk A B) = A := by simp [fst, mk, Universe.PtpEquiv.fst_mk] @@ -218,14 +222,13 @@ lemma Grpd.eqToHom_comp_heq {A B : Grpd} {C : Type*} [Category C] subst h simp [Grpd.id_eq_id, Functor.id_comp] -lemma snd_mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : - snd (mk A B) = map (eqToHom (fst_mk A B)) ⋙ B := by +lemma snd_mk (A A' : Γ ⥤ Grpd.{v,v}) (hA : A = A') (B : ∫(A) ⥤ C) : + snd (mk A B) A' (by rw [fst_mk, hA]) = map (eqToHom hA.symm) ⋙ B := by dsimp only [snd, mk] - rw! (castMode := .all) [Universe.PtpEquiv.fst_mk, Universe.PtpEquiv.snd_mk] - simp only [U_ext, U_Ty, Equiv.apply_eq_iff_eq_symm_apply, toCoreAsSmallEquiv_symm_apply_comp_left] - simp only [← heq_eq_eq, eqRec_heq_iff_heq, ← eqToHom_eq_homOf_map (fst_mk A B)] - symm - apply Grpd.eqToHom_comp_heq + subst hA + rw [Universe.PtpEquiv.snd_mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B)] + erw [Equiv.apply_symm_apply toCoreAsSmallEquiv B] + simp [map_id_eq] lemma snd_mk_heq (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : snd (mk A B) ≍ B := by @@ -236,8 +239,8 @@ end PtpEquiv def compDom := U.{v}.uvPolyTp.compDom U.{v}.uvPolyTp @[simp] -def comp : compDom.{v} ⟶ U.{v}.Ptp.obj Ty.{v} := - U.uvPolyTp.compP U.uvPolyTp +abbrev compP : compDom.{v} ⟶ U.{v}.Ptp.obj Ty.{v} := + Universe.compP U U namespace compDom @@ -258,8 +261,12 @@ A map `ab : (Γ) ⟶ compDom` is equivalently three functors `fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `dependent : Γ ⥤ Grpd` is `B : A → Type` in `(a : A) × (b : B a)`. -/ -def dependent : ∫(fst ab ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v} := - toCoreAsSmallEquiv (Universe.compDomEquiv.dependent ab) +def dependent (A := fst ab ⋙ PGrpd.forgetToGrpd) (eq : fst ab ⋙ PGrpd.forgetToGrpd = A := by rfl) : + ∫(A) ⥤ Grpd.{v,v} := + toCoreAsSmallEquiv (Universe.compDomEquiv.dependent ab (toCoreAsSmallEquiv.symm A) (by + simp only [U_Ty, U_Tm, compDomEquiv.fst, U_tp, ← eq] + erw [toCoreAsSmallEquiv_symm_apply_comp_right] + simp [fst]; rfl)) /-- Universal property of `compDom`, decomposition (part 3). @@ -270,7 +277,6 @@ is `(b : B a)` in `(a : A) × (b : B a)`. def snd : Γ ⥤ PGrpd.{v,v} := toCoreAsSmallEquiv (Universe.compDomEquiv.snd ab) -/- /-- Universal property of `compDom`, decomposition (part 4). A map `ab : (Γ) ⟶ compDom` is equivalently three functors @@ -284,101 +290,131 @@ theorem snd_forgetToGrpd : snd ab ⋙ PGrpd.forgetToGrpd = sec _ (fst ab) rfl rfl /-- Universal property of `compDom`, constructing a map into `compDom`. -/ -def mk (α : Γ ⥤ PGrpd.{v,v}) (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) - (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) - : (Γ) ⟶ compDom.{v} := - Universe.compDomEquiv.mk (toCoreAsSmallEquiv.symm α) rfl - (toCoreAsSmallEquiv.symm B) (toCoreAsSmallEquiv.symm β) (by - simp only [U_Ty, U_Tm, U_tp, tp, Grpd.comp_eq_comp, U_ext] - erw [← toCoreAsSmallEquiv_symm_apply_comp_right, h, - ← toCoreAsSmallEquiv_symm_apply_comp_left, sec_eq] - rfl +def mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) + (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) + (B : ∫(A) ⥤ Grpd.{v,v}) + (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : + Γ ⟶ compDom.{v} := + Universe.compDomEquiv.mk (toCoreAsSmallEquiv.symm α) (A := toCoreAsSmallEquiv.symm A) + (by rw [← hA, toCoreAsSmallEquiv_symm_apply_comp_right]; rfl) + (toCoreAsSmallEquiv.symm B) (toCoreAsSmallEquiv.symm β) + (by + dsimp [U_tp, tp, Grpd.comp_eq_comp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right β PGrpd.forgetToGrpd, h, + toCoreAsSmallEquiv_symm_apply_comp_left] + congr 1 + simp only [sec_eq, Equiv.apply_symm_apply] + rw! (castMode := .all) [toCoreAsSmallEquiv.apply_symm_apply] ) theorem fst_forgetToGrpd : fst ab ⋙ PGrpd.forgetToGrpd = - U.PtpEquiv.fst (ab ≫ comp.{v}) := by + U.PtpEquiv.fst (ab ≫ compP.{v}) := by erw [U.PtpEquiv.fst, ← compDomEquiv.fst_tp ab, ← toCoreAsSmallEquiv_apply_comp_right] rfl -theorem dependent_eq : dependent ab = - map (eqToHom (fst_forgetToGrpd ab)) ⋙ U.PtpEquiv.snd (ab ≫ comp.{v}) := by - dsimp only [dependent] - rw! [compDomEquiv.dependent_eq] - rw [Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left, eqToHom_eq_homOf_map, PtpEquiv.snd] - rfl +theorem dependent_eq (A := fst ab ⋙ PGrpd.forgetToGrpd) + (eq : fst ab ⋙ PGrpd.forgetToGrpd = A := by rfl) : dependent ab A eq = + map (eqToHom (by rw [← eq, fst_forgetToGrpd])) ⋙ U.PtpEquiv.snd (ab ≫ compP.{v}) := by + dsimp only [dependent, PtpEquiv.snd] + rw [Universe.compDomEquiv.dependent_eq _ _ _, ← toCoreAsSmallEquiv_apply_comp_left] + subst eq + rw! [← fst_forgetToGrpd] + simp [map_id_eq] -theorem dependent_heq : HEq (dependent ab) (U.PtpEquiv.snd (ab ≫ comp.{v})) := by +theorem dependent_heq : HEq (dependent ab) (U.PtpEquiv.snd (ab ≫ compP.{v})) := by rw [dependent_eq] apply Functor.precomp_heq_of_heq_id · rw [fst_forgetToGrpd] · rw [fst_forgetToGrpd] · apply map_eqToHom_heq_id_cod -theorem fst_naturality : fst ((σ) ≫ ab) = σ ⋙ fst ab := by +theorem fst_naturality : fst (σ ≫ ab) = σ ⋙ fst ab := by dsimp only [fst] - rw [← Universe.compDomEquiv.comp_fst, Grpd.comp_eq_comp, + rw [Universe.compDomEquiv.fst_comp, Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left] -theorem dependent_naturality : dependent ((σ) ≫ ab) = +theorem dependent_comp : dependent (σ ≫ ab) = map (eqToHom (by rw [fst_naturality, Functor.assoc])) ⋙ pre _ σ ⋙ dependent ab := by rw [dependent, dependent, ← Universe.compDomEquiv.comp_dependent (eq1 := rfl) - (eq2 := by simp [← compDomEquiv.comp_fst]), + (eq2 := by erw [← compDomEquiv.fst_comp_assoc, fst, toCoreAsSmallEquiv.eq_symm_apply]; rfl), substWk_eq] - rw! [Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left] rfl -theorem snd_naturality : snd (σ ≫ ab) = σ ⋙ snd ab := by +theorem snd_comp : snd (σ ≫ ab) = σ ⋙ snd ab := by dsimp only [snd] - rw [← Universe.compDomEquiv.comp_snd, Grpd.comp_eq_comp, + rw [Universe.compDomEquiv.snd_comp, Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left] /-- First component of the computation rule for `mk`. -/ -theorem fst_mk (α : Γ ⥤ PGrpd.{v,v}) - (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Γ ⥤ PGrpd.{v,v}) - (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) - : fst (mk α B β h) = α := by +theorem fst_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) + (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) + (B : ∫(A) ⥤ Grpd.{v,v}) + (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : + fst (mk α A hA B β h) = α := by simp [fst, mk, Universe.compDomEquiv.fst_mk] /-- Second component of the computation rule for `mk`. -/ -theorem dependent_mk (α : Γ ⥤ PGrpd.{v,v}) - (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Γ ⥤ PGrpd.{v,v}) - (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) - : dependent (mk α B β h) = map (eqToHom (by rw [fst_mk])) ⋙ B := by +theorem dependent_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) + (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) + (B : ∫(A) ⥤ Grpd.{v,v}) + (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : + dependent (mk α A hA B β h) = map (eqToHom (by subst hA; rw [fst_mk])) ⋙ B := by dsimp [dependent, mk] - rw [Equiv.apply_eq_iff_eq_symm_apply, toCoreAsSmallEquiv_symm_apply_comp_left] - rw! (castMode := .all) [compDomEquiv.fst_mk, compDomEquiv.dependent_mk] - simp only [U_Tm, U_ext, U_Ty, ← heq_eq_eq, eqRec_heq_iff_heq] - symm - apply map_eqToHom_comp_heq + rw [Equiv.apply_eq_iff_eq_symm_apply] + rw [compDomEquiv.dependent_mk] + · rw [toCoreAsSmallEquiv_symm_apply_comp_left] + erw [eqToHom_eq_homOf_map] + rfl + · simp [fst, compDomEquiv.fst_mk, hA] /-- Second component of the computation rule for `mk`. -/ -theorem snd_mk (α : Γ ⥤ PGrpd.{v,v}) - (B : ∫(α ⋙ PGrpd.forgetToGrpd) ⥤ Grpd.{v,v}) (β : Γ ⥤ PGrpd.{v,v}) - (h : β ⋙ PGrpd.forgetToGrpd = sec _ α rfl ⋙ B) - : snd (mk α B β h) = β := by +theorem snd_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) + (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) + (B : ∫(A) ⥤ Grpd.{v,v}) + (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : + snd (mk α A hA B β h) = β := by dsimp [snd, mk] rw [Universe.compDomEquiv.snd_mk] simp -theorem hext (ab1 ab2 : Γ ⟶ U.compDom.{v}) - (hfst : fst ab1 = fst ab2) (hdependent : HEq (dependent ab1) (dependent ab2)) +theorem ext (ab1 ab2 : Γ ⟶ U.compDom.{v}) + (hfst : fst ab1 = fst ab2) + (hdependent : dependent ab1 = map (eqToHom (by rw [hfst])) ⋙ dependent ab2) (hsnd : snd ab1 = snd ab2) : ab1 = ab2 := by dsimp only [compDom] at ab1 have h1 : compDomEquiv.fst ab1 = compDomEquiv.fst ab2 := by apply toCoreAsSmallEquiv.injective assumption fapply compDomEquiv.ext rfl h1 - · dsimp [dependent] at hdependent + · dsimp [dependent, fst] at hdependent apply toCoreAsSmallEquiv.injective - rw! (castMode := .all) [hdependent, h1] - simp [← heq_eq_eq]; rfl + convert hdependent + · rw [toCoreAsSmallEquiv_symm_apply_comp_right] + simp; rfl + rw! (castMode := .all) [toCoreAsSmallEquiv_symm_apply_comp_right, + Equiv.symm_apply_apply, h1, hfst] + simp [map_id_eq] + congr 1 + simp [← heq_eq_eq] + rfl · apply toCoreAsSmallEquiv.injective assumption +theorem hext (ab1 ab2 : Γ ⟶ U.compDom.{v}) + (hfst : fst ab1 = fst ab2) (hdependent : HEq (dependent ab1) (dependent ab2)) + (hsnd : snd ab1 = snd ab2) : ab1 = ab2 := by + apply ext + · rw! [hdependent] + simp [← heq_eq_eq] + conv => right; rw! (castMode := .all) [hfst] + simp [map_id_eq] + · assumption + · assumption + end compDom --/ + end U end diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index 8b78bca8..00b1706c 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -380,6 +380,7 @@ 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 .. @@ -392,12 +393,17 @@ 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)`. -/ -abbrev dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) +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 = Universe.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) : @@ -420,6 +426,7 @@ 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 .. @@ -432,7 +439,7 @@ 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) : + {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] @@ -454,11 +461,12 @@ theorem fst_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : (M.ext A) ⟶ simp [mk, fst] @[simp] -theorem dependent_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) - (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) +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 [fst_mk, eq]) = B := by - simp [mk] + 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) From 74246db0c6255f877710dc260c44c8cc3ab5ea14 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sat, 27 Sep 2025 23:07:35 -0400 Subject: [PATCH 09/59] attempt to make sigma helper --- .../ForMathlib/CategoryTheory/Polynomial.lean | 21 +- HoTTLean/Model/NaturalModel.lean | 217 +++++++++++-- HoTTLean/Model/UHom.lean | 298 +++++++++--------- 3 files changed, 365 insertions(+), 171 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index d4a776a7..1b6a839c 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -637,7 +637,6 @@ p' | (pb) | P @ B' -----> B fstProj -/ -@[simps!] 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 @@ -925,7 +924,7 @@ abbrev base (triple : Γ ⟶ compDom P P') : Γ ⟶ B := Equiv.fst (triple ≫ ( theorem fst_comp_p (triple : Γ ⟶ compDom P P') : fst triple ≫ P.p = base triple := by - simp [fst, Equiv.fst_eq, pullback.condition] + 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' := @@ -942,7 +941,7 @@ theorem snd_comp_p (triple : Γ ⟶ compDom 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_p, Equiv.snd'_eq] + simp only [← assoc, dependent, comp, Equiv.snd'_eq] congr 1 ext <;> simp [fst] @@ -956,11 +955,17 @@ def mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) 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] + 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) @@ -976,7 +981,7 @@ lemma dependent_mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = 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] + simp [mk, dependent, comp] @[simp] lemma snd_mk (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P.p = b) @@ -990,10 +995,10 @@ 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_p] + simp only [snd, assoc, ← pullback.condition, base, comp] simp only [hbase', Equiv.snd'_eq, ← Category.assoc] congr 1 - ext <;> simp [fst]) = triple := by + ext <;> simp [fst, comp]) = triple := by apply pullback.hom_ext · ext · simp [mk] @@ -1030,7 +1035,7 @@ lemma dependent_comp {Δ} (σ : Δ ⟶ Γ) (triple : Γ ⟶ compDom 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_p, ← assoc, Equiv.snd'_eq] + simp only [dependent, comp, ← assoc, Equiv.snd'_eq] congr ext <;> simp diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index 00b1706c..ab8870da 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -483,12 +483,8 @@ theorem ext {ab₁ ab₂ : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp} 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) : +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) (σ ≫ β) @@ -500,6 +496,12 @@ theorem comp_mk 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 @@ -507,23 +509,16 @@ theorem eta (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) end compDomEquiv -/-! ## Pi and Sigma types -/ +/-! ## 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 PiAux (U0 U1 U2 : Universe R) where +structure PolymorphicPi (U0 U1 U2 : Universe 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 -/-- The structure on three universes that for -`A : Γ ⟶ U0.Ty` and `B : Γ.A ⟶ U1.Ty` constructs a Π-type `Σ_A B : Γ ⟶ U2.Ty`. -/ -structure SigmaAux (U0 U1 U2 : Universe 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 - set_option linter.dupNamespace false in /-- A universe `M` has Π-type structure. This is the data of a pullback square ``` @@ -537,7 +532,16 @@ Ptp Ty ------> Ty Pi ``` -/ -protected abbrev Pi := PiAux M M M +protected abbrev Pi := PolymorphicPi M M M + +/-! ## 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 : Universe 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 ``` @@ -551,7 +555,184 @@ Ptp Ty ------> Ty pair ``` -/ -protected abbrev Sigma := SigmaAux M M M +protected abbrev Sigma := PolymorphicSigma M M M + +namespace PolymorphicSigma + +variable {U0 U1 U2 : Universe 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 + +def Hom.ofYoneda {C : Type*} [Category C] {X Y : C} + (app : ∀ {Γ}, (Γ ⟶ X) ⟶ (Γ ⟶ Y)) + (naturality : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (A), app (σ ≫ A) = σ ≫ app A) : + X ⟶ Y := + Yoneda.fullyFaithful.preimage { + app Γ := app + naturality Δ Γ σ := by ext; simp [naturality] } + +lemma Hom.ofYoneda_comp {C : Type*} [Category C] {TL TR BL BR : C} (left : TL ⟶ BL) (right : TR ⟶ BR) + (bottom : ∀ {Γ}, (Γ ⟶ BL) ⟶ (Γ ⟶ BR)) + (bottom_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (A), bottom (σ ≫ A) = σ ≫ bottom A) + (top : ∀ {Γ}, (Γ ⟶ TL) ⟶ (Γ ⟶ TR)) + (top_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (ab), top (σ ≫ ab) = σ ≫ top ab) + (comm_sq : ∀ {Γ} (ab : Γ ⟶ TL), top ab ≫ right = bottom (ab ≫ left)) : + (ofYoneda top top_comp) ≫ right = left ≫ (ofYoneda bottom bottom_comp) := by + apply Yoneda.fullyFaithful.map_injective + ext Γ ab + simp [comm_sq, ofYoneda] + +lemma IsPullback.ofYoneda {C : Type u} [Category.{v} C] + {P X Y Z : C} (fst : P ⟶ X) (snd : P ⟶ Y) (f : X ⟶ Z) (g : Y ⟶ Z) (w : fst ≫ f = snd ≫ g) + (h : IsPullback ym(fst) ym(snd) ym(f) ym(g)) : IsPullback fst snd f g := + IsPullback.of_isLimit (c := PullbackCone.mk fst snd w) (by + have : Nonempty (IsLimit (PullbackCone.mk fst snd w)) := by + apply Limits.ReflectsLimit.reflects (F := yoneda) + sorry + apply Classical.ofNonempty) + +#check IsPullback.isLimit + +def ofYoneda (S : ∀ {Γ}, (Γ ⟶ U0.Ptp.obj U1.Ty) ⟶ (Γ ⟶ U2.Ty)) + (S_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (A), S (σ ≫ A) = σ ≫ S A) + (pr : ∀ {Γ}, (Γ ⟶ U0.compDom U1) ⟶ (Γ ⟶ U2.Tm)) + (pr_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (ab), pr (σ ≫ ab) = σ ≫ pr ab) + (comm_sq : ∀ {Γ} (ab : Γ ⟶ U0.compDom U1), pr ab ≫ U2.tp = S (ab ≫ U0.compP U1)) : + PolymorphicSigma U0 U1 U2 where + Sig := Hom.ofYoneda S S_comp + pair := Hom.ofYoneda pr pr_comp + Sig_pullback := IsPullback.ofYoneda _ _ _ _ (Hom.ofYoneda_comp _ _ _ _ _ _ comm_sq) sorry + +end PolymorphicSigma /-- Universe.IdIntro consists of the following commutative square @@ -1253,8 +1434,6 @@ def toId' : M.Id' ii N where j_tp := i.j_tp comp_j := i.comp_j reflSubst_j := i.reflSubst_j --- TODO: prove the other half of the equivalence. --- Generalize this version so that the universe for elimination is not also `M` end Id diff --git a/HoTTLean/Model/UHom.lean b/HoTTLean/Model/UHom.lean index b3c5adc5..0281611c 100644 --- a/HoTTLean/Model/UHom.lean +++ b/HoTTLean/Model/UHom.lean @@ -626,7 +626,7 @@ theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j] assumption end Pi -/- + /-! ## Sigma -/ /-- The data of `Sig` and `pair` formers at each universe `s[i].tp`. -/ @@ -640,153 +640,163 @@ variable [s.SigSeq] def Sig : s[i].Ptp.obj s[j].Ty ⟶ s[max i j].Ty := s.cartesianNatTransTy i (max i j) j (max i j) ≫ (nmSig (max i j)).Sig -def pair : UvPoly.compDom s[i].uvPolyTp s[j].uvPolyTp ⟶ s[max i j].Tm := - let l : s[i].uvPolyTp.compDom s[j].uvPolyTp ⟶ s[max i j].uvPolyTp.compDom s[max i j].uvPolyTp := - UvPoly.compDomMap - (s.homOfLe i (max i j)).mapTm - (s.homOfLe j (max i j)).mapTm - (s.homOfLe i (max i j)).mapTy - (s.homOfLe j (max i j)).mapTy - (s.homOfLe i (max i j)).pb.flip - (s.homOfLe j (max i j)).pb.flip - l ≫ (nmSig (max i j)).pair +def pair : UvPoly.compDom s[i].uvPolyTp s[j].uvPolyTp ⟶ s[max i j].Tm := sorry + -- let l : s[i].uvPolyTp.compDom s[j].uvPolyTp ⟶ s[max i j].uvPolyTp.compDom s[max i j].uvPolyTp := + -- UvPoly.compDomMap + -- (s.homOfLe i (max i j)).mapTm + -- (s.homOfLe j (max i j)).mapTm + -- (s.homOfLe i (max i j)).mapTy + -- (s.homOfLe j (max i j)).mapTy + -- (s.homOfLe i (max i j)).pb.flip + -- (s.homOfLe j (max i j)).pb.flip + -- l ≫ (nmSig (max i j)).pair def Sig_pb : IsPullback (s.pair ilen jlen) - (s[i].uvPolyTp.compP s[j].uvPolyTp) s[max i j].tp - (s.Sig ilen jlen) := - (UvPoly.compDomMap_isPullback ..).paste_horiz (nmSig (max i j)).Sig_pullback - -/-- -``` -Γ ⊢ᵢ A Γ.A ⊢ⱼ B ------------------ -Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ΣA. B -``` -/ -def mkSig {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : - (Γ) ⟶ s[max i j].Ty := - PtpEquiv.mk s[i] A B ≫ s.Sig ilen jlen - -theorem comp_mkSig {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : - (σ) ≫ s.mkSig ilen jlen A B = - s.mkSig ilen jlen ((σ) ≫ A) ((s[i].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 : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : - (Γ) ⟶ s[max i j].Tm := - compDomEquiv.mk t t_tp B u u_tp ≫ s.pair ilen jlen - -theorem comp_mkPair {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : - (σ) ≫ s.mkPair ilen jlen A B t t_tp u u_tp = - s.mkPair ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) - ((σ) ≫ t) (by simp [t_tp]) - ((σ) ≫ u) (by simp [u_tp, comp_sec_functor_map_assoc]) := by - simp only [← Category.assoc, mkPair]; rw [compDomEquiv.comp_mk] - -@[simp] -theorem mkPair_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : - s.mkPair ilen jlen A B t t_tp u u_tp ≫ s[max i j].tp = s.mkSig ilen jlen A B := by - simp [mkPair, mkSig, UvPoly.compP, (s.Sig_pb ilen jlen).w, compDomEquiv.mk] - -def mkFst {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - (Γ) ⟶ s[i].Tm := - compDomEquiv.fst ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk _ A B) p_tp) - -@[simp] -theorem mkFst_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - s.mkFst ilen jlen A B p p_tp ≫ s[i].tp = A := by - simp [mkFst, UvPoly.compP, compDomEquiv.fst_tp] - -@[simp] -theorem mkFst_mkPair {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : - s.mkFst ilen jlen A B (s.mkPair ilen jlen 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_pb ilen jlen).hom_ext <;> [simp; simp [compDomEquiv.mk, UvPoly.compP]] - -theorem comp_mkFst {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - (σ) ≫ s.mkFst ilen jlen A B p p_tp = - s.mkFst ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) ((σ) ≫ p) - (by simp [p_tp, comp_mkSig]) := by - simp [mkFst] - rw [compDomEquiv.comp_fst]; congr 1 - apply (s.Sig_pb ilen jlen).hom_ext <;> simp - rw [PtpEquiv.mk_comp_left] + (s[i].compP s[j]) s[max i j].tp + (s.Sig ilen jlen) := sorry + -- (UvPoly.compDomMap_isPullback ..).paste_horiz (nmSig (max i j)).Sig_pullback + +def polymorphicSigma : PolymorphicSigma s[i] s[j] s[max i j] where + Sig := Sig s ilen jlen + pair := pair s ilen jlen + Sig_pullback := Sig_pb s ilen jlen + +-- NOTE: the commented out lemmas `lemma_name` are now called +-- from (s.polymorphicSigma ilen jlen).name + +-- /-- +-- ``` +-- Γ ⊢ᵢ A Γ.A ⊢ⱼ B +-- ----------------- +-- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ΣA. B +-- ``` -/ +-- def mkSig {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : +-- (Γ) ⟶ s[max i j].Ty := +-- PtpEquiv.mk s[i] A B ≫ s.Sig ilen jlen + +-- theorem comp_mkSig {Δ Γ : Ctx} (σ : Δ ⟶ Γ) +-- (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : +-- (σ) ≫ s.mkSig ilen jlen A B = +-- s.mkSig ilen jlen ((σ) ≫ A) ((s[i].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 : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) +-- (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : +-- (Γ) ⟶ s[max i j].Tm := +-- compDomEquiv.mk t t_tp B u u_tp ≫ s.pair ilen jlen + +-- theorem comp_mkPair {Δ Γ : Ctx} (σ : Δ ⟶ Γ) +-- (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) +-- (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : +-- (σ) ≫ s.mkPair ilen jlen A B t t_tp u u_tp = +-- s.mkPair ilen jlen ((σ) ≫ A) ((s[i].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 : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) +-- (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : +-- s.mkPair ilen jlen A B t t_tp u u_tp ≫ s[max i j].tp = s.mkSig ilen jlen A B := by +-- simp [mkPair, mkSig, (s.Sig_pb ilen jlen).w, compDomEquiv.mk] +-- sorry + +-- def mkFst {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +-- (Γ) ⟶ s[i].Tm := +-- compDomEquiv.fst ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk _ A B) p_tp) + +-- #exit +-- @[simp] +-- theorem mkFst_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +-- s.mkFst ilen jlen A B p p_tp ≫ s[i].tp = A := by +-- simp [mkFst, UvPoly.compP, compDomEquiv.fst_tp] + +-- @[simp] +-- theorem mkFst_mkPair {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) +-- (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : +-- s.mkFst ilen jlen A B (s.mkPair ilen jlen 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_pb ilen jlen).hom_ext <;> [simp; simp [compDomEquiv.mk, UvPoly.compP]] + +-- theorem comp_mkFst {Δ Γ : Ctx} (σ : Δ ⟶ Γ) +-- (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +-- (σ) ≫ s.mkFst ilen jlen A B p p_tp = +-- s.mkFst ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) ((σ) ≫ p) +-- (by simp [p_tp, comp_mkSig]) := by +-- simp [mkFst] +-- rw [compDomEquiv.comp_fst]; congr 1 +-- apply (s.Sig_pb ilen jlen).hom_ext <;> simp +-- rw [PtpEquiv.mk_comp_left] + +-- def mkSnd {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +-- (Γ) ⟶ s[j].Tm := +-- compDomEquiv.snd ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk _ A B) p_tp) + +-- @[simp] +-- theorem mkSnd_mkPair {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) +-- (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : +-- s.mkSnd ilen jlen A B (s.mkPair ilen jlen 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_pb ilen jlen).hom_ext <;> [simp; simp [compDomEquiv.mk, UvPoly.compP]] + +-- protected theorem dependent_eq {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +-- compDomEquiv.dependent ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk s[i] A B) p_tp) A +-- (by simp [compDomEquiv.fst_tp]) = B := by +-- simp [compDomEquiv.dependent, -UvPoly.comp_p] +-- convert PtpEquiv.snd_mk s[i] A B using 2 +-- simp + +-- @[simp] +-- theorem mkSnd_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +-- s.mkSnd ilen jlen A B p p_tp ≫ s[j].tp = +-- (s[i].sec A (s.mkFst ilen jlen 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 : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +-- (σ) ≫ s.mkSnd ilen jlen A B p p_tp = +-- s.mkSnd ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) ((σ) ≫ p) +-- (by simp [p_tp, comp_mkSig]) := by +-- simp [mkSnd, compDomEquiv.comp_snd]; congr 1 +-- apply (s.Sig_pb ilen jlen).hom_ext <;> simp +-- rw [PtpEquiv.mk_comp_left] + +-- @[simp] +-- theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : +-- s.mkPair ilen jlen A B +-- (s.mkFst ilen jlen A B p p_tp) (by simp) +-- (s.mkSnd ilen jlen A B p p_tp) (by simp) = p := by +-- simp [mkFst, mkSnd, mkPair] +-- have := compDomEquiv.eta ((s.Sig_pb ilen jlen).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 Sigma -def mkSnd {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - (Γ) ⟶ s[j].Tm := - compDomEquiv.snd ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk _ A B) p_tp) - -@[simp] -theorem mkSnd_mkPair {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (t : (Γ) ⟶ s[i].Tm) (t_tp : t ≫ s[i].tp = A) - (u : (Γ) ⟶ s[j].Tm) (u_tp : u ≫ s[j].tp = (s[i].sec A t t_tp) ≫ B) : - s.mkSnd ilen jlen A B (s.mkPair ilen jlen 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_pb ilen jlen).hom_ext <;> [simp; simp [compDomEquiv.mk, UvPoly.compP]] - -protected theorem dependent_eq {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - compDomEquiv.dependent ((s.Sig_pb ilen jlen).lift p (PtpEquiv.mk s[i] A B) p_tp) A - (by simp [compDomEquiv.fst_tp]) = B := by - simp [compDomEquiv.dependent, -UvPoly.comp_p] - convert PtpEquiv.snd_mk s[i] A B using 2 - simp - -@[simp] -theorem mkSnd_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - s.mkSnd ilen jlen A B p p_tp ≫ s[j].tp = - (s[i].sec A (s.mkFst ilen jlen 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 : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - (σ) ≫ s.mkSnd ilen jlen A B p p_tp = - s.mkSnd ilen jlen ((σ) ≫ A) ((s[i].substWk σ A) ≫ B) ((σ) ≫ p) - (by simp [p_tp, comp_mkSig]) := by - simp [mkSnd, compDomEquiv.comp_snd]; congr 1 - apply (s.Sig_pb ilen jlen).hom_ext <;> simp - rw [PtpEquiv.mk_comp_left] - -@[simp] -theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (p : (Γ) ⟶ s[max i j].Tm) (p_tp : p ≫ s[max i j].tp = s.mkSig ilen jlen A B) : - s.mkPair ilen jlen A B - (s.mkFst ilen jlen A B p p_tp) (by simp) - (s.mkSnd ilen jlen A B p p_tp) (by simp) = p := by - simp [mkFst, mkSnd, mkPair] - have := compDomEquiv.eta ((s.Sig_pb ilen jlen).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 Sigma --/ /-! ## Identity types -/ class IdSeq (s : UHomSeq R) where From abb4e347bdb38819155391221412ac1228dda049 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 28 Sep 2025 16:47:51 -0400 Subject: [PATCH 10/59] refactor: Groupoid model Sigma --- HoTTLean/ForMathlib.lean | 57 +++++ HoTTLean/Groupoids/NaturalModelBase.lean | 4 +- HoTTLean/Groupoids/Sigma.lean | 256 +++++++++++------------ HoTTLean/Model/NaturalModel.lean | 53 ++--- 4 files changed, 193 insertions(+), 177 deletions(-) diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index 07f5f108..110008ee 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -624,6 +624,63 @@ end CategoryTheory.IsPullback namespace CategoryTheory +def ofYoneda {C : Type*} [Category C] {X Y : C} + (app : ∀ {Γ}, (Γ ⟶ X) ⟶ (Γ ⟶ Y)) + (naturality : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (A), app (σ ≫ A) = σ ≫ app A) : + X ⟶ Y := + Yoneda.fullyFaithful.preimage { + app Γ := app + naturality Δ Γ σ := by ext; simp [naturality] } + +@[simp] +lemma ofYoneda_comp_left {C : Type*} [Category C] {X Y : C} + (app : ∀ {Γ}, (Γ ⟶ X) ⟶ (Γ ⟶ Y)) + (naturality : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (A), app (σ ≫ A) = σ ≫ app A) + {Γ} (A : Γ ⟶ X) : A ≫ ofYoneda app naturality = app A := by + apply Yoneda.fullyFaithful.map_injective + ext + simp [ofYoneda, naturality] + +lemma ofYoneda_comm_sq {C : Type*} [Category C] {TL TR BL BR : C} + (left : TL ⟶ BL) (right : TR ⟶ BR) + (top : ∀ {Γ}, (Γ ⟶ TL) ⟶ (Γ ⟶ TR)) + (top_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (tr), top (σ ≫ tr) = σ ≫ top tr) + (bottom : ∀ {Γ}, (Γ ⟶ BL) ⟶ (Γ ⟶ BR)) + (bottom_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (br), bottom (σ ≫ br) = σ ≫ bottom br) + (comm_sq : ∀ {Γ} (ab : Γ ⟶ TL), top ab ≫ right = bottom (ab ≫ left)) : + (ofYoneda top top_comp) ≫ right = left ≫ (ofYoneda bottom bottom_comp) := by + apply Yoneda.fullyFaithful.map_injective + ext Γ ab + simp [comm_sq, ofYoneda] + +open Limits in +lemma ofYoneda_isPullback {C : Type u} [Category.{v} C] {TL TR BL BR : C} + (left : TL ⟶ BL) (right : TR ⟶ BR) + (top : ∀ {Γ}, (Γ ⟶ TL) ⟶ (Γ ⟶ TR)) + (top_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (tr), top (σ ≫ tr) = σ ≫ top tr) + (bot : ∀ {Γ}, (Γ ⟶ BL) ⟶ (Γ ⟶ BR)) + (bot_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (br), bot (σ ≫ br) = σ ≫ bot br) + (comm_sq : ∀ {Γ} (ab : Γ ⟶ TL), top ab ≫ right = bot (ab ≫ left)) + (lift : ∀ {Γ} (t : Γ ⟶ TR) (p) (ht : t ≫ right = bot p), Γ ⟶ TL) + (top_lift : ∀ {Γ} (t : Γ ⟶ TR) (p) (ht : t ≫ right = bot p), top (lift t p ht) = t) + (lift_comp_left : ∀ {Γ} (t : Γ ⟶ TR) (p) (ht : t ≫ right = bot p), lift t p ht ≫ left = p) + (lift_uniq : ∀ {Γ} (t : Γ ⟶ TR) (p) (ht : t ≫ right = bot p) (m : Γ ⟶ TL), + top m = t → m ≫ left = p → m = lift t p ht) : + IsPullback (ofYoneda top top_comp) left right (ofYoneda bot bot_comp) := by + let c : PullbackCone right (ofYoneda bot bot_comp) := + PullbackCone.mk (ofYoneda top top_comp) left + (ofYoneda_comm_sq _ _ _ _ _ _ comm_sq) + apply IsPullback.of_isLimit (c := c) + apply c.isLimitAux (fun s => lift (PullbackCone.fst s) (PullbackCone.snd s) (by + simp [PullbackCone.condition s])) + · simp [c, top_lift] + · simp [c, lift_comp_left] + · intro s m h + apply lift_uniq + · specialize h (some .left) + simpa [c] using h + · 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), diff --git a/HoTTLean/Groupoids/NaturalModelBase.lean b/HoTTLean/Groupoids/NaturalModelBase.lean index ac9ce8cf..1409cb9d 100644 --- a/HoTTLean/Groupoids/NaturalModelBase.lean +++ b/HoTTLean/Groupoids/NaturalModelBase.lean @@ -328,13 +328,13 @@ theorem dependent_heq : HEq (dependent ab) (U.PtpEquiv.snd (ab ≫ compP.{v})) : · rw [fst_forgetToGrpd] · apply map_eqToHom_heq_id_cod -theorem fst_naturality : fst (σ ≫ ab) = σ ⋙ fst ab := by +theorem fst_comp : fst (σ ≫ ab) = σ ⋙ fst ab := by dsimp only [fst] rw [Universe.compDomEquiv.fst_comp, Grpd.comp_eq_comp, toCoreAsSmallEquiv_apply_comp_left] theorem dependent_comp : dependent (σ ≫ ab) = - map (eqToHom (by rw [fst_naturality, Functor.assoc])) + map (eqToHom (by rw [fst_comp, Functor.assoc])) ⋙ pre _ σ ⋙ dependent ab := by rw [dependent, dependent, ← Universe.compDomEquiv.comp_dependent (eq1 := rfl) diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index 20e586e7..df92695e 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -50,19 +50,6 @@ def sigmaMap : sigmaObj B x ⥤ sigmaObj B y := theorem ιNatTrans_app_base (a : sigmaObj B x) : ((ιNatTrans f).app a.base) = homMk f (𝟙 (A.map f).obj a.base) := rfl --- theorem sigmaMap_obj (a) : (sigmaMap B f).obj a = --- objMk ((A.map f).obj a.base) --- ((B.map --- (homMk --- (X := (ι A x).obj (base a)) --- (Y := (ι A y).obj ((A.map f).obj (base a))) f --- (𝟙 _))).obj (a.fiber)) := by --- apply hext --- · simp --- · simp only [sigmaObj, sigmaMap_obj_base, Functor.comp_obj, sigmaMap_obj_fiber, ι_obj_base, --- ι_obj_fiber, objMk_base, objMk_fiber, heq_eq_eq] --- congr - @[simp] theorem sigmaMap_map_base {a b : sigmaObj B x} {p : a ⟶ b} : ((sigmaMap B f).map p).base = (A.map f).map p.base := rfl @@ -536,15 +523,6 @@ theorem ι_sigma_comp_map_fstAux (x) : ι (sigma A B) x ⋙ map (fstAux B) · rfl · simp --- lemma asFunctorFrom_fib_map_fstAux {x : Γ} : --- asFunctorFrom_fib (map (fstAux B)) x = ι (sigma A B) x ⋙ map (fstAux B) := --- rfl - --- lemma asFunctorFrom_hom_map_fstAux {c c' : Γ} (f : c ⟶ c') : --- asFunctorFrom_hom (map (fstAux B)) f = --- Functor.whiskerRight (ιNatTrans f) (map (fstAux B)) := by --- sorry - theorem functorFrom_comp_fib_assocFib_forget : functorFrom_comp_fib (assocFib B) forget = asFunctorFrom_fib (map (fstAux B)) := by ext x @@ -811,68 +789,75 @@ end sigma end FunctorOperation -/- open FunctorOperation /-- Behavior of the Σ-type former (a natural transformation) on an input. By Yoneda, "an input" is the same as a map from a representable into the domain. -/ -def smallUSig.Sig_app {Γ : Ctx} - (AB : y(Γ) ⟶ smallU.{v}.Ptp.obj smallU.{v}.Ty) : - y(Γ) ⟶ smallU.{v}.Ty := - yonedaCategoryEquiv.symm (sigma _ (smallU.PtpEquiv.snd AB)) +def USig.Sig_app {Γ : Ctx} + (AB : Γ ⟶ U.{v}.Ptp.obj U.{v}.Ty) : + Γ ⟶ U.{v}.Ty := + toCoreAsSmallEquiv.symm (sigma _ (U.PtpEquiv.snd AB)) /-- Naturality for the formation rule for Σ-types. Also known as Beck-Chevalley -/ -theorem smallUSig.Sig_naturality {Γ Δ : Ctx} (σ : Δ ⟶ Γ) - (AB : y(Γ) ⟶ smallU.{v}.Ptp.obj smallU.{v}.Ty) : - smallUSig.Sig_app (ym(σ) ≫ AB) = ym(σ) ≫ smallUSig.Sig_app AB := by - dsimp only [smallUSig.Sig_app] - rw [← yonedaCategoryEquiv_symm_naturality_left, sigma_naturality, +theorem USig.Sig_naturality {Γ Δ : Ctx} (σ : Δ ⟶ Γ) + (AB : Γ ⟶ U.{v}.Ptp.obj U.{v}.Ty) : + USig.Sig_app ((σ) ≫ AB) = (σ) ≫ USig.Sig_app AB := by + dsimp only [USig.Sig_app] + slice_rhs 1 2 => rw [Grpd.comp_eq_comp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left] + rw [sigma_naturality] -- note the order of rewrite is first the fiber, then the base -- this allows rw! to cast the proof in the `eqToHom` - smallU.PtpEquiv.snd_comp_left] - rw! [smallU.PtpEquiv.fst_comp_left] - congr 2 - · simp [map_id_eq, Functor.id_comp] + conv => left; rw! [U.PtpEquiv.fst_comp_left] + rw [U.PtpEquiv.snd_comp_left] + congr 1 + simp [map_id_eq, Functor.id_comp] /-- The formation rule for Σ-types for the ambient natural model `base` If possible, don't use NatTrans.app on this, instead precompose it with maps from representables. -/ -def smallUSig.Sig : smallU.{v}.Ptp.obj smallU.{v}.Ty - ⟶ smallU.{v}.Ty := - NatTrans.yonedaMk smallUSig.Sig_app smallUSig.Sig_naturality - -lemma smallUSig.Sig_app_eq {Γ : Ctx} (AB : y(Γ) ⟶ _) : AB ≫ smallUSig.Sig = - smallUSig.Sig_app AB := by - simp only [smallUSig.Sig, NatTrans.yonedaMk_app] - -open smallU.compDom - -def smallUSig.pair_app {Γ : Ctx} - (ab : y(Γ) ⟶ smallU.{v}.uvPolyTp.compDom smallU.{v}.uvPolyTp) - : y(Γ) ⟶ smallU.{v}.Tm := - yonedaCategoryEquiv.symm (pair _ _ _ (snd_forgetToGrpd ab)) - -theorem smallUSig.pair_naturality {Γ Δ : Ctx} (f : Δ ⟶ Γ) - (ab : y(Γ) ⟶ smallU.compDom.{v}) : - smallUSig.pair_app (ym(f) ≫ ab) = ym(f) ≫ smallUSig.pair_app ab := by - dsimp only [smallUSig.pair_app] - rw [← yonedaCategoryEquiv_symm_naturality_left, FunctorOperation.pair_naturality] - -- Like with `smallUSig.Sig_naturality` rw from inside to outside (w.r.t type dependency) - rw! (castMode := .all) [dependent_naturality, snd_naturality, fst_naturality] +def USig.Sig : U.{v}.Ptp.obj U.{v}.Ty ⟶ U.{v}.Ty := + ofYoneda USig.Sig_app USig.Sig_naturality + +lemma USig.Sig_app_eq {Γ : Ctx} (AB : Γ ⟶ _) : AB ≫ USig.Sig = + USig.Sig_app AB := by + simp [USig.Sig] + +open U.compDom + +def USig.pair_app {Γ : Ctx} (ab : Γ ⟶ U.{v}.uvPolyTp.compDom U.{v}.uvPolyTp) : + Γ ⟶ U.{v}.Tm := + toCoreAsSmallEquiv.symm (pair _ _ _ (snd_forgetToGrpd ab)) + +theorem USig.pair_naturality {Γ Δ : Ctx} (f : Δ ⟶ Γ) + (ab : Γ ⟶ U.compDom.{v}) : + USig.pair_app ((f) ≫ ab) = (f) ≫ USig.pair_app ab := by + dsimp only [USig.pair_app] + slice_rhs 1 2 => rw [Grpd.comp_eq_comp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left] + rw [FunctorOperation.pair_naturality] + -- Like with `USig.Sig_naturality` rw from inside to outside (w.r.t type dependency) + rw! (castMode := .all) [dependent_comp, snd_comp, fst_comp] simp [map_id_eq, Functor.id_comp] -def smallUSig.pair : smallU.compDom.{v} ⟶ smallU.{v}.Tm := - NatTrans.yonedaMk smallUSig.pair_app smallUSig.pair_naturality +def USig.pair : U.compDom.{v} ⟶ U.{v}.Tm := + ofYoneda USig.pair_app USig.pair_naturality -lemma smallUSig.pair_app_eq {Γ : Ctx} (ab : y(Γ) ⟶ _) : ab ≫ smallUSig.pair = - yonedaCategoryEquiv.symm (FunctorOperation.pair _ _ _ (snd_forgetToGrpd ab)) := by - simp only [smallUSig.pair, smallUSig.pair_app, NatTrans.yonedaMk_app] +lemma USig.pair_comp_left {Γ : Ctx} (ab : Γ ⟶ _) : ab ≫ USig.pair = + USig.pair_app ab := by + simp [USig.pair] + +theorem USig.pair_tp {Γ : Ctx} (ab : Γ ⟶ _) : pair_app ab ≫ U.tp = Sig_app (ab ≫ U.compP) := by + simp [pair_app, Sig_app] + erw [← toCoreAsSmallEquiv_symm_apply_comp_right, pair_comp_forgetToGrpd] + rw! (castMode := .all) [fst_forgetToGrpd, Grpd.comp_eq_comp] + rfl namespace SigPullback @@ -880,46 +865,49 @@ open Limits section -theorem smallUSig.pair_tp : smallUSig.pair.{v} ≫ smallU.{v}.tp = - smallU.comp.{v} ≫ smallUSig.Sig.{v} := by - apply hom_ext_yoneda - intros Γ ab - rw [← Category.assoc, ← Category.assoc, smallUSig.pair_app_eq, - smallUSig.Sig_app_eq, smallU_tp, π, - ← yonedaCategoryEquiv_symm_naturality_right, - pair_comp_forgetToGrpd, smallUSig.Sig_app] - congr 2 - · rw [fst_forgetToGrpd] - · exact dependent_heq.{v} ab - section -variable {Γ : Ctx} (AB : y(Γ) ⟶ smallU.Ptp.obj.{v} y(U.{v})) - (αβ : y(Γ) ⟶ y(E.{v})) (hαβ : αβ ≫ ym(π) = AB ≫ smallUSig.Sig) +variable {Γ : Ctx} (AB : Γ ⟶ U.Ptp.obj.{v} U.Ty.{v}) + (αβ : Γ ⟶ U.Tm.{v}) (hαβ : αβ ≫ U.tp = USig.Sig_app AB) include hαβ in -theorem yonedaCategoryEquiv_forgetToGrpd : yonedaCategoryEquiv αβ ⋙ forgetToGrpd - = sigma (smallU.PtpEquiv.fst AB) (smallU.PtpEquiv.snd AB) := by - erw [← yonedaCategoryEquiv_naturality_right, hαβ] - rw [smallUSig.Sig_app_eq, smallUSig.Sig_app, yonedaCategoryEquiv.apply_symm_apply] - -def lift : y(Γ) ⟶ smallU.compDom.{v} := - let β' := smallU.PtpEquiv.snd AB - let αβ' := yonedaCategoryEquiv αβ - let hαβ' : yonedaCategoryEquiv αβ ⋙ forgetToGrpd - = sigma (smallU.PtpEquiv.fst AB) (smallU.PtpEquiv.snd AB) := - yonedaCategoryEquiv_forgetToGrpd _ _ hαβ - mk (sigma.fst' β' αβ' hαβ') (sigma.dependent' β' αβ' hαβ') +theorem toCoreAsSmallEquiv_forgetToGrpd : toCoreAsSmallEquiv αβ ⋙ forgetToGrpd + = sigma (U.PtpEquiv.fst AB) (U.PtpEquiv.snd AB) := by + erw [← toCoreAsSmallEquiv_apply_comp_right, + ← Grpd.comp_eq_comp, hαβ] + rw [USig.Sig_app, toCoreAsSmallEquiv.apply_symm_apply] + +def lift : Γ ⟶ U.compDom.{v} := + let β' := U.PtpEquiv.snd AB + let αβ' := toCoreAsSmallEquiv αβ + let hαβ' : toCoreAsSmallEquiv αβ ⋙ forgetToGrpd + = sigma (U.PtpEquiv.fst AB) (U.PtpEquiv.snd AB) := + toCoreAsSmallEquiv_forgetToGrpd _ _ hαβ + U.compDom.mk (sigma.fst' β' αβ' hαβ') _ rfl (sigma.dependent' β' αβ' hαβ') (sigma.snd' β' αβ' hαβ') (sigma.snd'_forgetToGrpd β' αβ' hαβ') -theorem fac_left : lift.{v} AB αβ hαβ ≫ smallUSig.pair.{v} = αβ := by - rw [smallUSig.pair_app_eq] - dsimp only [lift] - rw! (castMode := .all) [dependent_mk, snd_mk, fst_mk] - simp only [eqToHom_refl, map_id_eq, Cat.of_α, Functor.id_comp] - rw [yonedaCategoryEquiv.symm_apply_eq, sigma.eta] - -theorem fac_right : lift.{v} AB αβ hαβ ≫ smallU.comp.{v} = AB := by - apply smallU.PtpEquiv.hext +lemma fst_lift : fst (lift AB αβ hαβ) = + sigma.fst' (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) + (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by + simp [lift, fst_mk] + +lemma snd_lift : snd (lift AB αβ hαβ) = sigma.snd' + (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) + (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by + simp [lift, snd_mk] + +lemma dependent_lift : dependent (lift AB αβ hαβ) = + map (eqToHom (by rw [fst_lift AB αβ hαβ])) ⋙ sigma.dependent' + (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) + (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by + simp [lift, dependent_mk] + +theorem pair_app_lift : USig.pair_app (SigPullback.lift AB αβ hαβ) = αβ := by + rw [USig.pair_app, toCoreAsSmallEquiv.symm_apply_eq] + rw! [dependent_lift, snd_lift, fst_lift] + simp [eqToHom_refl, map_id_eq, sigma.eta] + +theorem lift_compP : lift.{v} AB αβ hαβ ≫ U.compP.{v} = AB := by + apply U.PtpEquiv.hext · rw [← fst_forgetToGrpd] dsimp only [lift] rw [fst_mk, sigma.fst'_forgetToGrpd] @@ -929,26 +917,27 @@ theorem fac_right : lift.{v} AB αβ hαβ ≫ smallU.comp.{v} = AB := by simp [map_id_eq, Functor.id_comp] apply map_eqToHom_comp_heq -theorem hom_ext (m n : y(Γ) ⟶ smallU.compDom.{v}) - (hComp : m ≫ smallU.comp = n ≫ smallU.comp) - (hPair : m ≫ smallUSig.pair = n ≫ smallUSig.pair) : m = n := by +theorem hom_ext (m n : Γ ⟶ U.compDom) + (hComp : m ≫ U.compP.{v} = n ≫ U.compP) + (hPair : m ≫ USig.pair = n ≫ USig.pair) : + m = n := by have h : (pair (fst m) (snd m) (dependent m) (snd_forgetToGrpd m)) = (pair (fst n) (snd n) (dependent n) (snd_forgetToGrpd n)) := calc _ - _ = yonedaCategoryEquiv (m ≫ smallUSig.pair) := by - simp [smallUSig.pair_app_eq m] - _ = yonedaCategoryEquiv (n ≫ smallUSig.pair) := by rw [hPair] + _ = toCoreAsSmallEquiv (m ≫ USig.pair) := by + simp [USig.pair_comp_left m, USig.pair_app] + _ = toCoreAsSmallEquiv (n ≫ USig.pair) := by rw [hPair] _ = _ := by - simp [smallUSig.pair_app_eq n] + simp [USig.pair_comp_left n, USig.pair_app] + have : fst m ⋙ forgetToGrpd = fst n ⋙ forgetToGrpd := by + rw [fst_forgetToGrpd, fst_forgetToGrpd, hComp] have hdep : HEq (dependent m) (dependent n) := by refine (dependent_heq _).trans $ HEq.trans ?_ $ (dependent_heq _).symm rw [hComp] - have : fst m ⋙ forgetToGrpd = fst n ⋙ forgetToGrpd := by - rw [fst_forgetToGrpd, fst_forgetToGrpd, hComp] - apply smallU.compDom.hext + fapply U.compDom.hext · calc fst m _ = sigma.fst' _ (FunctorOperation.pair (fst m) (snd m) (dependent m) (snd_forgetToGrpd m)) _ := @@ -956,7 +945,7 @@ theorem hom_ext (m n : y(Γ) ⟶ smallU.compDom.{v}) _ = sigma.fst' _ (FunctorOperation.pair (fst n) (snd n) (dependent n) (snd_forgetToGrpd n)) _ := by rw! [h] - congr! + congr! 1 _ = fst n := sigma.fst'_pair _ · exact hdep · calc snd m @@ -969,45 +958,42 @@ theorem hom_ext (m n : y(Γ) ⟶ smallU.compDom.{v}) congr! _ = snd n := sigma.snd'_pair _ -theorem uniq (m : y(Γ) ⟶ smallU.compDom) - (hmAB : m ≫ smallU.comp = AB) (hmαβ : m ≫ smallUSig.pair = αβ) : +theorem uniq (m : Γ ⟶ U.compDom) + (hl : USig.pair_app m = αβ) + (hr : m ≫ U.compP = AB) : m = lift AB αβ hαβ := by apply hom_ext - · rw [hmAB, fac_right] - · rw [hmαβ, fac_left] + · rw [hr, lift_compP] + · rw [USig.pair_comp_left, hl, USig.pair_comp_left, pair_app_lift] end end end SigPullback -open SigPullback +theorem USig.isPullback : IsPullback USig.pair U.compP.{v,u} U.tp.{v,u} USig.Sig := + ofYoneda_isPullback _ _ _ _ _ _ (fun ab => USig.pair_tp ab) + (fun αβ AB hαβ => SigPullback.lift AB αβ hαβ) + (fun αβ AB hαβ => SigPullback.pair_app_lift AB αβ hαβ) + (fun αβ AB hαβ => SigPullback.lift_compP.{v,u} AB αβ hαβ) + (fun αβ AB hαβ m hl hr => SigPullback.uniq.{v,u} AB αβ hαβ m hl hr) -theorem smallUSig.isPullback : IsPullback smallUSig.pair.{v,u} smallU.comp.{v,u} - smallU.{v, u}.tp smallUSig.Sig.{v, u} := - Limits.RepPullbackCone.is_pullback smallUSig.pair_tp.{v,u} - (fun s => lift s.snd s.fst s.condition) - (fun s => fac_left.{v,u} _ _ s.condition) - (fun s => fac_right.{v,u} _ _ s.condition) - (fun s m fac_left fac_right => uniq.{v,u} _ _ s.condition m fac_right fac_left) +def USig : Universe.Sigma U.{v} where + Sig := USig.Sig + pair := USig.pair + Sig_pullback := USig.isPullback -def smallUSig : Universe.Sigma smallU.{v} where - Sig := smallUSig.Sig - pair := smallUSig.pair - Sig_pullback := smallUSig.isPullback - -def uHomSeqSigs' (i : ℕ) (ilen : i < 4) : - Universe.Sigma (uHomSeqObjs i ilen) := +def liftSeqSigs' (i : ℕ) (ilen : i < 4) : + Universe.Sigma (liftSeqObjs i ilen) := match i with - | 0 => smallUSig.{0, 4} - | 1 => smallUSig.{1, 4} - | 2 => smallUSig.{2, 4} - | 3 => smallUSig.{3, 4} + | 0 => USig.{0, 4} + | 1 => USig.{1, 4} + | 2 => USig.{2, 4} + | 3 => USig.{3, 4} | (n+4) => by omega -instance uHomSeqSigma : uHomSeq.SigSeq where - nmSig := uHomSeqSigs' --/ +instance liftSeqSigma : liftSeq.SigSeq where + nmSig := liftSeqSigs' end GroupoidModel end diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index ab8870da..8d1d345d 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -692,48 +692,21 @@ theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty end -def Hom.ofYoneda {C : Type*} [Category C] {X Y : C} - (app : ∀ {Γ}, (Γ ⟶ X) ⟶ (Γ ⟶ Y)) - (naturality : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (A), app (σ ≫ A) = σ ≫ app A) : - X ⟶ Y := - Yoneda.fullyFaithful.preimage { - app Γ := app - naturality Δ Γ σ := by ext; simp [naturality] } - -lemma Hom.ofYoneda_comp {C : Type*} [Category C] {TL TR BL BR : C} (left : TL ⟶ BL) (right : TR ⟶ BR) - (bottom : ∀ {Γ}, (Γ ⟶ BL) ⟶ (Γ ⟶ BR)) - (bottom_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (A), bottom (σ ≫ A) = σ ≫ bottom A) - (top : ∀ {Γ}, (Γ ⟶ TL) ⟶ (Γ ⟶ TR)) - (top_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (ab), top (σ ≫ ab) = σ ≫ top ab) - (comm_sq : ∀ {Γ} (ab : Γ ⟶ TL), top ab ≫ right = bottom (ab ≫ left)) : - (ofYoneda top top_comp) ≫ right = left ≫ (ofYoneda bottom bottom_comp) := by - apply Yoneda.fullyFaithful.map_injective - ext Γ ab - simp [comm_sq, ofYoneda] - -lemma IsPullback.ofYoneda {C : Type u} [Category.{v} C] - {P X Y Z : C} (fst : P ⟶ X) (snd : P ⟶ Y) (f : X ⟶ Z) (g : Y ⟶ Z) (w : fst ≫ f = snd ≫ g) - (h : IsPullback ym(fst) ym(snd) ym(f) ym(g)) : IsPullback fst snd f g := - IsPullback.of_isLimit (c := PullbackCone.mk fst snd w) (by - have : Nonempty (IsLimit (PullbackCone.mk fst snd w)) := by - apply Limits.ReflectsLimit.reflects (F := yoneda) - sorry - apply Classical.ofNonempty) - -#check IsPullback.isLimit - -def ofYoneda (S : ∀ {Γ}, (Γ ⟶ U0.Ptp.obj U1.Ty) ⟶ (Γ ⟶ U2.Ty)) - (S_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (A), S (σ ≫ A) = σ ≫ S A) - (pr : ∀ {Γ}, (Γ ⟶ U0.compDom U1) ⟶ (Γ ⟶ U2.Tm)) - (pr_comp : ∀ {Δ Γ} (σ : Δ ⟶ Γ) (ab), pr (σ ≫ ab) = σ ≫ pr ab) - (comm_sq : ∀ {Γ} (ab : Γ ⟶ U0.compDom U1), pr ab ≫ U2.tp = S (ab ≫ U0.compP U1)) : - PolymorphicSigma U0 U1 U2 where - Sig := Hom.ofYoneda S S_comp - pair := Hom.ofYoneda pr pr_comp - Sig_pullback := IsPullback.ofYoneda _ _ _ _ (Hom.ofYoneda_comp _ _ _ _ _ _ comm_sq) sorry - 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 (substWk M σ A σA eq ≫ B)).hom ≫ substWk M σ _ _ (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 From 331e4ae128178d73413fe982899e809b5ba47c2f Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 28 Sep 2025 18:39:03 -0400 Subject: [PATCH 11/59] pushforwardPullbackTwoSquare --- .../CategoryTheory/BeckChevalley.lean | 389 ++++++++++++++++++ .../ForMathlib/CategoryTheory/Polynomial.lean | 144 +++++-- HoTTLean/Model/NaturalModel.lean | 11 - 3 files changed, 506 insertions(+), 38 deletions(-) create mode 100644 HoTTLean/ForMathlib/CategoryTheory/BeckChevalley.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/BeckChevalley.lean b/HoTTLean/ForMathlib/CategoryTheory/BeckChevalley.lean new file mode 100644 index 00000000..8320fd90 --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/BeckChevalley.lean @@ -0,0 +1,389 @@ +/- +Copyright (c) 2025 Sina Hazratpour. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sina Hazratpour, Emily Riehl, Joseph Hua +-/ +import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction +import Mathlib.CategoryTheory.MorphismProperty.Composition +import Mathlib.CategoryTheory.Limits.Shapes.Pullback.CommSq + +/-! +# Beck-Chevalley natural transformations and natural isomorphisms + +We construct the so-called Beck-Chevalley natural transformations and isomorphisms through the +repeated applications of the mate construction in the vertical and horizontal directions. + +## Main declarations + +- `Over.mapIsoSquare`: The isomorphism between the functors `Over.map h ⋙ Over.map g` and + `Over.map f ⋙ Over.map k` for a commutative square of morphisms `h ≫ g = f ≫ k`. + +- `Over.pullbackMapTwoSquare`: The Beck-Chevalley natural transformation of a commutative + square of morphisms `h ≫ g = f ≫ k`. + +- `Over.pullbackForgetTriangle`: The natural transformation `pullback f ⋙ forget X ⟶ forget Y`. + +- `Over.pullbackIsoSquare`: The isomorphism between the pullbacks along a commutative square of + morphisms `h ≫ g = f ≫ k`. + +- `Over.pushforwardBeckChevalleySquare`: The Beck-Chevalley natural transformation for a commutative + square of morphisms `h ≫ g = f ≫ k` in the slice category `Over Y`. + +- `Over.pushforwardSquareIso`: The isomorphism between the pushforwards along a commutative + square of morphisms `h ≫ g = f ≫ k`. + +## Implementation notes +The lax naturality squares are constructed by the mate equivalence `mateEquiv` and +the natural iso-squares are constructed by the more special conjugation equivalence +`conjugateIsoEquiv`. + +## References + +The methodology and the notation of the successive mate constructions to obtain the Beck-Chevalley +natural transformations and isomorphisms are based on the following paper: + +* [A 2-categorical proof of Frobenius for fibrations defined from a generic point, +in Mathematical Structures in Computer Science, 2024][Hazratpour_Riehl_2024] + +-/ + +noncomputable section +namespace CategoryTheory + +open Category Functor Adjunction Limits NatTrans + +universe v u + +namespace Over + +variable {C : Type u} [Category.{v} C] + +section BeckChevalleyTrans + +--h ≫ g = f ≫ k -- h → k +theorem map_square_eq {X Y Z W : C} {h : X ⟶ Z} {f : X ⟶ Y} {g : Z ⟶ W} {k : Y ⟶ W} + (sq : CommSq h f g k := by aesop) : + Over.map h ⋙ Over.map g = Over.map f ⋙ Over.map k := by + rw [← mapComp_eq, sq.w, mapComp_eq] + +/-- Promoting the equality `mapSquare_eq` of functors to an isomorphism. +``` + Over X -- .map h -> Over Z + | | + .map f | ≅ | .map g + ↓ ↓ + Over Y -- .map k -> Over W +``` +The Beck Chevalley transformations are iterated mates of this isomorphism in the +horizontal and vertical directions. -/ +def mapIsoSquare {X Y Z W : C} {h : X ⟶ Z} {f : X ⟶ Y} {g : Z ⟶ W} {k : Y ⟶ W} + (sq : CommSq h f g k := by aesop) : + Over.map h ⋙ Over.map g ≅ Over.map f ⋙ Over.map k := + eqToIso (map_square_eq sq) + +variable {X Y Z W : C} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) + (sq : CommSq h f g k) + [∀ {P : C} (h : P ⟶ Y), HasPullback h f] + [∀ {P : C} (h : P ⟶ W), HasPullback h g] + [∀ {P : C} (h : P ⟶ W), HasPullback h k] + [∀ {P : C} (h' : P ⟶ Z), HasPullback h' h] + +/-- The Beck-Chevalley natural transformation `pullback f ⋙ map h ⟶ map k ⋙ pullback g` +constructed as a mate of `mapIsoSquare`: +``` + Over Y - pullback f → Over X + | | +map k | ↙ | map h + ↓ ↓ + Over W - pullback g → Over Z +``` +-/ +--pullbackBeckChevalleySquare +def pullbackMapTwoSquare : TwoSquare (pullback f) (map k) (map h) (pullback g) := + mateEquiv (mapPullbackAdj f) (mapPullbackAdj g) (mapIsoSquare sq).hom + +/-- +The natural transformation `pullback f ⋙ forget X ⟶ forget Y ⋙ 𝟭 C` +as the mate of the isomorphism `mapForget f`: +``` + Over Y - pullback f → Over X + | | +forget Y | ↙ | forget X + ↓ ↓ + C ======== 𝟭 ======== C +``` +-/ +def pullbackForgetTwoSquare : TwoSquare (pullback f) (forget Y) (forget X) (𝟭 C) := + mateEquiv (mapPullbackAdj f) Adjunction.id (mapForget f).inv + +-- theorem isCartesian_pullbackForgetTwoSquare {X Y : C} (f : X ⟶ Y) : +-- NatTrans.IsCartesian (pullbackForgetTwoSquare f) := by +-- unfold pullbackForgetTwoSquare +-- simp only [mateEquiv_apply] +-- repeat apply IsCartesian.comp; apply isCartesian_of_isIso +-- apply IsCartesian.comp +-- . apply IsCartesian.whiskerRight +-- apply isCartesian_mapPullbackAdj_counit +-- . apply isCartesian_of_isIso + +/-- The natural transformation `pullback f ⋙ forget X ⟶ forget Y`, a variant of +`pullbackForgetTwoSquare`. -/ +--pullbackForgetBeckChevalleyTriangle +def pullbackForgetTriangle : + pullback f ⋙ forget X ⟶ forget Y := + pullbackForgetTwoSquare f + +/-- The natural transformation `pullback f ⋙ map h ⟶ map h'` for a triangle `f : h ⟶ h'`. -/ +--pullbackMapBeckChevalleyTriangle +def pullbackMapTriangle (h' : Y ⟶ Z) (w : f ≫ h' = h) : + pullback f ⋙ map h ⟶ map h' := by + let iso := (mapComp f h').hom + rw [w] at iso + rw [← Functor.comp_id (map h)] at iso + exact (mateEquiv (mapPullbackAdj f) Adjunction.id) iso + +/-- The isomorphism between the pullbacks along a commutative square. This is constructed as the +conjugate of the `mapIsoSquare`. +``` + Over X ←--.pullback h-- Over Z + ↑ ↑ +.pullback f | ≅ | .pullback g + | | + Over Y ←--.pullback k-- Over W +``` +-/ +--pullbackSquareIso +def pullbackIsoSquare : pullback k ⋙ pullback f ≅ pullback g ⋙ pullback h := + conjugateIsoEquiv ((mapPullbackAdj f).comp (mapPullbackAdj k)) + ((mapPullbackAdj h).comp (mapPullbackAdj g)) (mapIsoSquare sq) + +end BeckChevalleyTrans +end Over + +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] + [R.IsStableUnderComposition] + {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶(Q) Y) (g : Z ⟶(Q) W) (k : Y ⟶ W) + (sq : CommSq h f.1 g.1 k) + +instance : MorphismProperty.HasOfPostcompProperty (C := T) ⊤ ⊤ where + of_postcomp := sorry + +/-- The Beck-Chevalley natural transformation +`pushforward g ⋙ pullback k ⟶ pullback h ⋙ pushforward f` constructed as a mate of +`pullbackMapTwoSquare`. +``` + R.Over ⊤ Z - pushforward g → R.Over ⊤ W + | | +pullback h | ↙ | pullback k + V V + R.Over ⊤ X - pushforward f → R.Over ⊤ Y +``` +-/ +--pushforwardBeckChevalleySquare +def pushforwardPullbackTwoSquare : + TwoSquare (MorphismProperty.pushforward (P := R) (Q := Q) g) + (MorphismProperty.Over.pullback R ⊤ h) + (MorphismProperty.Over.pullback R ⊤ k) + (MorphismProperty.pushforward (P := R) (Q := Q) f) := + mateEquiv (MorphismProperty.pullbackPushforwardAdjunction R Q g) + (MorphismProperty.pullbackPushforwardAdjunction R Q f) + ((MorphismProperty.Over.pullbackComp _ _).inv ≫ + eqToHom (by rw! [sq.w]) ≫ + (MorphismProperty.Over.pullbackComp _ _).hom) + -- conjugateEquiv (mapPullbackAdj k |>.comp <| MorphismProperty.pullbackPushforwardAdjunction g) + -- (MorphismProperty.pullbackPushforwardAdjunction R Q f |>.comp <| + -- MorphismProperty.Over.mapPullbackAdj R ⊤ h) + -- (Over.pullbackMapTwoSquare h f.1 g.1 k sq) + +-- /-- +-- A variant of `pushforwardTwoSquare` involving `star` instead of `pullback`. +-- -/ +-- --pushforwardStarBeckChevalleySquare +-- def starPushforwardTriangle [HasBinaryProducts C] [ExponentiableMorphism f] : +-- star Y ⟶ star X ⋙ pushforward f := by +-- let iso := (starPullbackIsoStar f).hom +-- rw [← Functor.id_comp (star X)] at iso +-- exact (mateEquiv Adjunction.id (adj f)) iso + +-- /-- The conjugate isomorphism between the pushforwards along a commutative square. +-- ``` +-- Over X --.pushforward h -→ Over Z +-- | | +-- .pushforward f | ≅ | .pushforward g +-- ↓ ↓ +-- Over Y --.pushforward k -→ Over W +-- ``` +-- -/ +-- def pushforwardIsoSquare [ExponentiableMorphism f] [ExponentiableMorphism g] +-- [ExponentiableMorphism h] [ExponentiableMorphism k] : +-- pushforward h ⋙ pushforward g ≅ pushforward f ⋙ pushforward k := +-- conjugateIsoEquiv (adj g |>.comp <| adj h) (adj k |>.comp <| adj f) (pullbackIsoSquare h f g k sq) + +-- end BeckChevalleyTrans + +-- end Over + +-- section BeckChevalleyComponents + +-- variable {C : Type u} [Category.{v} C] + +-- namespace IsPullback + +-- /-- +-- In a commutative cube diagram if the front, back and the right face are pullback squares then +-- the the left face is also a pullback square. +-- ``` +-- P ---p₂------ X +-- /| /| +-- i₄ / | i₂ / | +-- / | / | f₂ +-- Q ----q₂----- Z | +-- | | | | +-- | W -f₁----- | - S +-- q₁ | / | / +-- | / i₁ | / i₃ +-- |/ |/ +-- Y ----g₁------ T +-- ``` +-- -/ +-- theorem left_face_of_comm_cube {P W X Y Q Z S T : C} +-- (p₁ : P ⟶ W) (p₂ : P ⟶ X) (f₁ : W ⟶ S) (f₂ : X ⟶ S) +-- (q₁ : Q ⟶ Y) (q₂ : Q ⟶ Z) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) +-- (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) (i₄ : P ⟶ Q) +-- (sq_top : CommSq p₂ i₄ i₂ q₂) +-- (sq_bot : CommSq f₁ i₁ i₃ g₁) +-- (sq_left : CommSq i₄ p₁ q₁ i₁) +-- (pb_back : IsPullback p₂ p₁ f₂ f₁) +-- (pb_front : IsPullback q₂ q₁ g₂ g₁) +-- (pb_right : IsPullback i₂ f₂ g₂ i₃) : +-- IsPullback i₄ p₁ q₁ i₁ := by +-- have paste_horiz_pb := paste_horiz pb_back pb_right +-- rw [sq_top.w, sq_bot.w] at paste_horiz_pb +-- exact of_right paste_horiz_pb sq_left.w pb_front + +-- /-- +-- In a commutative cube diagram if the front, the left and the right face are pullback squares then +-- the the back face is also a pullback square. +-- ``` +-- P ---p₂------ X +-- /| /| +-- i₄ / | i₂ / | +-- / | / | f₂ +-- Q ----q₂----- Z | +-- | | | | +-- | W -f₁----- | - S +-- q₁ | / | / +-- | / i₁ | / i₃ +-- |/ |/ +-- Y ----g₁------ T +-- ``` +-- -/ +-- theorem back_face_of_comm_cube {P W X Y Q Z S T : C} +-- (p₁ : P ⟶ W) (p₂ : P ⟶ X) (f₁ : W ⟶ S) (f₂ : X ⟶ S) +-- (q₁ : Q ⟶ Y) (q₂ : Q ⟶ Z) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) +-- (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) (i₄ : P ⟶ Q) +-- (sq_top : CommSq p₂ i₄ i₂ q₂) +-- (sq_bot : CommSq f₁ i₁ i₃ g₁) +-- (sq_back : CommSq p₂ p₁ f₂ f₁) +-- (pb_front : IsPullback q₂ q₁ g₂ g₁) +-- (pb_left : IsPullback i₄ p₁ q₁ i₁) +-- (pb_right : IsPullback i₂ f₂ g₂ i₃) : +-- IsPullback p₂ p₁ f₂ f₁ := by +-- have paste_horiz_pb := paste_horiz pb_left pb_front +-- rw [← sq_top.w, ← sq_bot.w] at paste_horiz_pb +-- exact of_right paste_horiz_pb sq_back.w pb_right + +-- /-- The pullback comparison map `pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃` between two +-- pullback squares is an isomorphism if `i₁` is an isomorphism and one of the +-- connecting morphisms is an isomorphism. -/ +-- theorem pullback.map_isIso_of_pullback_right_of_comm_cube {W X Y Z S T : C} +-- (f₁ : W ⟶ S) (f₂ : X ⟶ S) [HasPullback f₁ f₂] +-- (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) [HasPullback g₁ g₂] +-- (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) +-- (sq_bot : CommSq f₁ i₁ i₃ g₁) +-- [IsIso i₁] (pb_right : IsPullback i₂ f₂ g₂ i₃) : +-- IsIso (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ sq_bot.w pb_right.w.symm) := by +-- let m := pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ sq_bot.w pb_right.w.symm +-- have sq_top : CommSq (pullback.snd f₁ f₂) m i₂ (pullback.snd g₁ g₂) := by +-- aesop +-- have sq_left : CommSq m (pullback.fst f₁ f₂) (pullback.fst g₁ g₂) i₁ := by +-- aesop +-- let pb' : IsPullback m (pullback.fst f₁ f₂) (pullback.fst g₁ g₂) i₁ := by +-- apply IsPullback.left_face_of_comm_cube (sq_top := sq_top) (sq_bot := sq_bot) +-- (sq_left := sq_left) (pb_back := (IsPullback.of_hasPullback f₁ f₂).flip) +-- (pb_front := (IsPullback.of_hasPullback g₁ g₂).flip) +-- (pb_right := pb_right) +-- have is_iso : IsIso m := IsPullback.isIso_fst_of_isIso pb' +-- exact is_iso + +-- end IsPullback + +-- variable [HasPullbacks C] + +-- variable {X Y Z W : C} {h : X ⟶ Z} {f : X ⟶ Y} {g : Z ⟶ W} {k : Y ⟶ W} +-- (sq : CommSq h f g k) (A : Over Y) + +-- open IsPullback Over + +-- theorem mapPullbackAdj.counit_app_left : +-- ((mapPullbackAdj f).counit.app A).left = pullback.fst _ _ := by +-- simp only [mapPullbackAdj_counit_app, homMk_left] + +-- @[simp] +-- theorem pullbackMapTwoSquare_app : +-- (pullbackMapTwoSquare h f g k sq).app A = +-- Over.homMk (pullback.map _ _ (A.hom ≫ k) _ _ h k (id_comp _).symm sq.w.symm) (by aesop) := by +-- ext +-- simp only [homMk_left, pullbackMapTwoSquare, mapIsoSquare] +-- aesop + +-- theorem forget_map_pullbackMapTwoSquare : +-- (forget Z).map ((pullbackMapTwoSquare h f g k sq).app A) = +-- pullback.map _ _ _ _ (𝟙 _) h k (id_comp _).symm sq.w.symm := by +-- simp only [forget_map, pullbackMapTwoSquare_app, homMk_left] + +-- theorem isIso_forgetMappullbackMapTwoSquare_of_isPullback (pb : IsPullback h f g k) : +-- IsIso ((forget Z).map ((pullbackMapTwoSquare h f g k pb.toCommSq).app A)) := by +-- rw [forget_map_pullbackMapTwoSquare (sq:= pb.toCommSq)] +-- let paste_horiz_pb := paste_horiz (IsPullback.of_hasPullback f A.hom) pb +-- apply pullback.map_isIso_of_pullback_right_of_comm_cube +-- assumption' +-- aesop + +-- /-- The pullback Beck-Chevalley natural transformation of a pullback square is an isomorphism. -/ +-- instance pullbackMapTwoSquare_of_isPullback_isIso (pb : IsPullback h f g k) : +-- IsIso (pullbackMapTwoSquare h f g k pb.toCommSq) := by +-- apply (config := { allowSynthFailures:= true}) NatIso.isIso_of_isIso_app +-- intro A +-- have := isIso_forgetMappullbackMapTwoSquare_of_isPullback A pb +-- exact ReflectsIsomorphisms.reflects (forget Z) +-- ((pullbackMapTwoSquare h f g k pb.toCommSq).app A) + +-- /-- The pullback-map exchange isomorphism. -/ +-- def pullbackMapIsoSquare (pb : IsPullback h f g k) : +-- pullback f ⋙ map h ≅ Over.map k ⋙ Over.pullback g := by +-- refine @asIso _ _ _ _ (pullbackMapTwoSquare h f g k pb.toCommSq) ?_ +-- exact pullbackMapTwoSquare_of_isPullback_isIso pb + +-- /-- The functor Beck-Chevalley natural transformation of a pullback square is an isomorphism. -/ +-- instance pushforwardPullbackTwoSquare_of_isPullback_isIso (pb : IsPullback h f g k) +-- [ExponentiableMorphism f] [ExponentiableMorphism g] : +-- IsIso (pushforwardPullbackTwoSquare h f g k pb.toCommSq) := by +-- have := pullbackMapTwoSquare_of_isPullback_isIso pb +-- apply conjugateEquiv_iso + +-- /-- The pullback-pushforward exchange isomorphism. -/ +-- def pushforwardPullbackIsoSquare (pb : IsPullback h f g k) +-- [ExponentiableMorphism f] [ExponentiableMorphism g] : +-- pushforward g ⋙ pullback k ≅ pullback h ⋙ pushforward f := by +-- refine @asIso _ _ _ _ (pushforwardPullbackTwoSquare h f g k pb.toCommSq) ?_ +-- exact pushforwardPullbackTwoSquare_of_isPullback_isIso pb + +-- end BeckChevalleyComponents + +-- end CategoryTheory + +-- end diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 1b6a839c..97c00436 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -22,6 +22,32 @@ variable {C : Type u} [Category.{v} C] namespace MorphismProperty +/-- The Beck-Chevalley natural transformation +`pushforward g ⋙ pullback k ⟶ pullback h ⋙ pushforward f` constructed as a mate of +`pullbackMapTwoSquare`. +``` + R.Over ⊤ Z - pushforward g → R.Over ⊤ W + | | +pullback h | ↙ | pullback k + V V + R.Over ⊤ X - pushforward f → R.Over ⊤ Y +``` +-/ +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 (MorphismProperty.pushforward (P := R) (Q := Q) g) + (MorphismProperty.Over.pullback R ⊤ h) + (MorphismProperty.Over.pullback R ⊤ k) + (MorphismProperty.pushforward (P := R) (Q := Q) f) := + mateEquiv (MorphismProperty.pullbackPushforwardAdjunction R Q g) + (MorphismProperty.pullbackPushforwardAdjunction R Q f) + ((MorphismProperty.Over.pullbackComp _ _).inv ≫ + eqToHom (by rw! [sq]) ≫ + (MorphismProperty.Over.pullbackComp _ _).hom) + namespace PolynomialPartialAdjunction variable {T : Type u} [Category.{v} T] {R : MorphismProperty T} @@ -110,6 +136,42 @@ def counit : 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 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 : Over.pullback R ⊤ i' ⋙ Over.pullback R ⊤ ρ ⟶ Over.pullback R ⊤ i := + (cellLeftIso).hom + let cellMid := push + sorry + end PolynomialPartialAdjunction variable (P : MorphismProperty C) @@ -215,8 +277,7 @@ 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 : C) where - (E B : C) +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) @@ -232,7 +293,7 @@ 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 -variable {I O : C} (P : MvPoly R H I O) [R.HasPullbacks] [R.IsStableUnderBaseChange] +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] @@ -241,7 +302,7 @@ 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) (X : R.Over ⊤ I) : R.Over ⊤ P.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`. @@ -268,13 +329,13 @@ to `X^ (E b)`. O ``` -/ -def sndProj (P : MvPoly R H I O) (X : R.Over ⊤ I) : +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) {X Y : R.Over ⊤ I} (f : X ⟶ Y) +variable (P : MvPoly R H I O E B) {X Y : R.Over ⊤ I} (f : X ⟶ Y) @[reassoc (attr := simp)] lemma map_fstProj : @@ -315,16 +376,16 @@ 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) : R.Over ⊤ I → R.Over ⊤ O := (functor P).obj +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} {Γ : Over O} {X : R.Over ⊤ I} +variable {P : MvPoly R H I O E B} {Γ : Over O} {X : R.Over ⊤ I} -def fst (pair : Γ ⟶ (P @ X).toComma) : Over P.B := Over.mk (pair.left ≫ (fstProj P X).hom) +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) @@ -336,17 +397,17 @@ lemma snd_eq (pair : Γ ⟶ (P @ X).toComma) : snd pair = erw [Equiv.apply_eq_iff_eq_symm_apply, ← homEquiv_comp_symm] simp [sndProj, counit] -def mk (f : Over P.B) (hf : Γ = (Over.map P.o.1).obj f) +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 P.B) (hf : Γ = (Over.map P.o.1).obj f) +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 P.B) (hf : Γ = (Over.map P.o.1).obj f) +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 @@ -371,16 +432,44 @@ lemma eta (pair : Γ ⟶ (P @ X).toComma) : mk (fst pair) (by simp) (snd pair) = end Equiv -instance (P : MvPoly R H I O) : Limits.PreservesLimitsOfShape WalkingCospan +instance (P : MvPoly R H I O E B) : Limits.PreservesLimitsOfShape WalkingCospan (MorphismProperty.Over.map ⊤ P.o.2) := by sorry -instance (P : MvPoly R H I O) : +instance (P : MvPoly R H I O E B) : Limits.PreservesLimitsOfShape WalkingCospan (MvPoly.functor P) := by dsimp [functor] have : (MorphismProperty.Over.pullback R ⊤ P.i.1).IsRightAdjoint := Adjunction.isRightAdjoint (MorphismProperty.Over.mapPullbackAdj R ⊤ P.i.1 P.i.2 trivial) 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 ` 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 V ‖ +R.Over ⊤ I ----> R.Over ⊤ E ----> R.Over ⊤ B -----> R.Over ⊤ O + P.p.1 +``` +-/ +def verticalNatTrans {F : C} (P : MvPoly R H I O E B) (Q : MvPoly R H I O F B) (ρ : E ⟶ F) + (h : P.p.1 = ρ ≫ Q.p.1) : Q.functor ⟶ P.functor := sorry + end MvPoly /-- `P : UvPoly R E B` is the type of signatures for polynomial functors @@ -452,9 +541,7 @@ abbrev fromOverTerminal : R.Over ⊤ (⊤_ C) ⥤ C := (equivalenceOfHasObjects R terminalIsTerminal).functor @[simps] -def mvPoly (P : UvPoly R E B) : MvPoly R R (⊤_ C) (⊤_ C) where - E := E - B := B +def mvPoly (P : UvPoly R E B) : MvPoly R R (⊤_ C) (⊤_ C) E B where i := object E p := ⟨P.p, P.morphismProperty⟩ o := object B @@ -509,29 +596,32 @@ lemma sndProj_comp (P : UvPoly R E B) {X Y : C} (f : X ⟶ Y) : open TwoSquare -/-- A vertical map `ρ : P.p.1 ⟶ Q.p.1` of polynomials (i.e. a commutative triangle) +/-- A commutative triangle ``` - ρ -E ----> F - \ / - \ / \ / - B + ρ +E -------> F + \ / +p \ / q + ↘ ↙ + B ``` -induces a natural transformation `Q.functor ⟶ P.functor ` obtained by pasting the following 2-cells +induces a natural transformation `Q.functor ⟶ P.functor` +obtained by pasting the following 2-cells ``` Q.p.1 C --- > C/F ----> C/B -----> C | | | | -| ↙ | ρ* ≅ | = | +| ↙ | ρ* ≅ | = | | v v | C --- > C/E ----> C/B ----> C P.p.1 ``` -/ 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 := sorry --by - -- have sq : CommSq ρ P.p.1 Q.p.1 (𝟙 _) := by simp [h] + (h : P.p = ρ ≫ Q.p) : Q.functor ⟶ P.functor := -- let cellLeft := (Over.starPullbackIsoStar ρ).hom + sorry --by + -- have sq : CommSq ρ P.p.1 Q.p.1 (𝟙 _) := by simp [h] -- let cellMid := (pushforwardPullbackTwoSquare ρ P.p Q.p (𝟙 _) sq) -- let cellLeftMidPasted := TwoSquare.whiskerRight (cellLeft ≫ₕ cellMid) (Over.pullbackId).inv -- simpa using (cellLeftMidPasted ≫ₕ (vId (forget B))) diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index 8d1d345d..43381a7d 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -334,17 +334,6 @@ theorem PtpEquiv.mk_map {Γ : Ctx} {X Y : Ctx} /-! ## Polynomial composition `M.tp ▸ N.tp` -/ --- -- `private` lemma for the equivalence below. --- private lemma lift_ev {Γ : Ctx} {N : Universe Ctx} --- {AB : Γ ⟶ M.Ptp.obj N.Ty} {α : Γ ⟶ M.Tm} --- (hA : AB ≫ M.uvPolyTp.fstProj N.Ty = α ≫ M.tp) : --- pullback.lift AB α hA ≫ (UvPoly.PartialProduct.fan M.uvPolyTp N.Ty).snd = --- (M.sec (α ≫ M.tp) α rfl) ≫ --- (M.disp_pullback _).lift (M.var _) (M.disp _) --- (by dsimp; rw [hA, (M.disp_pullback _).w]) ≫ --- (M.Ptp_equiv AB).2 := --- sorry - abbrev compDom (M N : Universe R) : Ctx := M.uvPolyTp.compDom N.uvPolyTp abbrev compP (M N : Universe R) : M.compDom N ⟶ M.uvPolyTp @ N.Ty := From 5918d59336d9797cfbe4ba63d7165b7dd9dabee0 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 28 Sep 2025 20:50:32 -0400 Subject: [PATCH 12/59] feat: verticalNatTrans --- .../CategoryTheory/BeckChevalley.lean | 389 ------------------ .../ForMathlib/CategoryTheory/Polynomial.lean | 91 ++-- 2 files changed, 57 insertions(+), 423 deletions(-) delete mode 100644 HoTTLean/ForMathlib/CategoryTheory/BeckChevalley.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/BeckChevalley.lean b/HoTTLean/ForMathlib/CategoryTheory/BeckChevalley.lean deleted file mode 100644 index 8320fd90..00000000 --- a/HoTTLean/ForMathlib/CategoryTheory/BeckChevalley.lean +++ /dev/null @@ -1,389 +0,0 @@ -/- -Copyright (c) 2025 Sina Hazratpour. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Sina Hazratpour, Emily Riehl, Joseph Hua --/ -import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction -import Mathlib.CategoryTheory.MorphismProperty.Composition -import Mathlib.CategoryTheory.Limits.Shapes.Pullback.CommSq - -/-! -# Beck-Chevalley natural transformations and natural isomorphisms - -We construct the so-called Beck-Chevalley natural transformations and isomorphisms through the -repeated applications of the mate construction in the vertical and horizontal directions. - -## Main declarations - -- `Over.mapIsoSquare`: The isomorphism between the functors `Over.map h ⋙ Over.map g` and - `Over.map f ⋙ Over.map k` for a commutative square of morphisms `h ≫ g = f ≫ k`. - -- `Over.pullbackMapTwoSquare`: The Beck-Chevalley natural transformation of a commutative - square of morphisms `h ≫ g = f ≫ k`. - -- `Over.pullbackForgetTriangle`: The natural transformation `pullback f ⋙ forget X ⟶ forget Y`. - -- `Over.pullbackIsoSquare`: The isomorphism between the pullbacks along a commutative square of - morphisms `h ≫ g = f ≫ k`. - -- `Over.pushforwardBeckChevalleySquare`: The Beck-Chevalley natural transformation for a commutative - square of morphisms `h ≫ g = f ≫ k` in the slice category `Over Y`. - -- `Over.pushforwardSquareIso`: The isomorphism between the pushforwards along a commutative - square of morphisms `h ≫ g = f ≫ k`. - -## Implementation notes -The lax naturality squares are constructed by the mate equivalence `mateEquiv` and -the natural iso-squares are constructed by the more special conjugation equivalence -`conjugateIsoEquiv`. - -## References - -The methodology and the notation of the successive mate constructions to obtain the Beck-Chevalley -natural transformations and isomorphisms are based on the following paper: - -* [A 2-categorical proof of Frobenius for fibrations defined from a generic point, -in Mathematical Structures in Computer Science, 2024][Hazratpour_Riehl_2024] - --/ - -noncomputable section -namespace CategoryTheory - -open Category Functor Adjunction Limits NatTrans - -universe v u - -namespace Over - -variable {C : Type u} [Category.{v} C] - -section BeckChevalleyTrans - ---h ≫ g = f ≫ k -- h → k -theorem map_square_eq {X Y Z W : C} {h : X ⟶ Z} {f : X ⟶ Y} {g : Z ⟶ W} {k : Y ⟶ W} - (sq : CommSq h f g k := by aesop) : - Over.map h ⋙ Over.map g = Over.map f ⋙ Over.map k := by - rw [← mapComp_eq, sq.w, mapComp_eq] - -/-- Promoting the equality `mapSquare_eq` of functors to an isomorphism. -``` - Over X -- .map h -> Over Z - | | - .map f | ≅ | .map g - ↓ ↓ - Over Y -- .map k -> Over W -``` -The Beck Chevalley transformations are iterated mates of this isomorphism in the -horizontal and vertical directions. -/ -def mapIsoSquare {X Y Z W : C} {h : X ⟶ Z} {f : X ⟶ Y} {g : Z ⟶ W} {k : Y ⟶ W} - (sq : CommSq h f g k := by aesop) : - Over.map h ⋙ Over.map g ≅ Over.map f ⋙ Over.map k := - eqToIso (map_square_eq sq) - -variable {X Y Z W : C} (h : X ⟶ Z) (f : X ⟶ Y) (g : Z ⟶ W) (k : Y ⟶ W) - (sq : CommSq h f g k) - [∀ {P : C} (h : P ⟶ Y), HasPullback h f] - [∀ {P : C} (h : P ⟶ W), HasPullback h g] - [∀ {P : C} (h : P ⟶ W), HasPullback h k] - [∀ {P : C} (h' : P ⟶ Z), HasPullback h' h] - -/-- The Beck-Chevalley natural transformation `pullback f ⋙ map h ⟶ map k ⋙ pullback g` -constructed as a mate of `mapIsoSquare`: -``` - Over Y - pullback f → Over X - | | -map k | ↙ | map h - ↓ ↓ - Over W - pullback g → Over Z -``` --/ ---pullbackBeckChevalleySquare -def pullbackMapTwoSquare : TwoSquare (pullback f) (map k) (map h) (pullback g) := - mateEquiv (mapPullbackAdj f) (mapPullbackAdj g) (mapIsoSquare sq).hom - -/-- -The natural transformation `pullback f ⋙ forget X ⟶ forget Y ⋙ 𝟭 C` -as the mate of the isomorphism `mapForget f`: -``` - Over Y - pullback f → Over X - | | -forget Y | ↙ | forget X - ↓ ↓ - C ======== 𝟭 ======== C -``` --/ -def pullbackForgetTwoSquare : TwoSquare (pullback f) (forget Y) (forget X) (𝟭 C) := - mateEquiv (mapPullbackAdj f) Adjunction.id (mapForget f).inv - --- theorem isCartesian_pullbackForgetTwoSquare {X Y : C} (f : X ⟶ Y) : --- NatTrans.IsCartesian (pullbackForgetTwoSquare f) := by --- unfold pullbackForgetTwoSquare --- simp only [mateEquiv_apply] --- repeat apply IsCartesian.comp; apply isCartesian_of_isIso --- apply IsCartesian.comp --- . apply IsCartesian.whiskerRight --- apply isCartesian_mapPullbackAdj_counit --- . apply isCartesian_of_isIso - -/-- The natural transformation `pullback f ⋙ forget X ⟶ forget Y`, a variant of -`pullbackForgetTwoSquare`. -/ ---pullbackForgetBeckChevalleyTriangle -def pullbackForgetTriangle : - pullback f ⋙ forget X ⟶ forget Y := - pullbackForgetTwoSquare f - -/-- The natural transformation `pullback f ⋙ map h ⟶ map h'` for a triangle `f : h ⟶ h'`. -/ ---pullbackMapBeckChevalleyTriangle -def pullbackMapTriangle (h' : Y ⟶ Z) (w : f ≫ h' = h) : - pullback f ⋙ map h ⟶ map h' := by - let iso := (mapComp f h').hom - rw [w] at iso - rw [← Functor.comp_id (map h)] at iso - exact (mateEquiv (mapPullbackAdj f) Adjunction.id) iso - -/-- The isomorphism between the pullbacks along a commutative square. This is constructed as the -conjugate of the `mapIsoSquare`. -``` - Over X ←--.pullback h-- Over Z - ↑ ↑ -.pullback f | ≅ | .pullback g - | | - Over Y ←--.pullback k-- Over W -``` --/ ---pullbackSquareIso -def pullbackIsoSquare : pullback k ⋙ pullback f ≅ pullback g ⋙ pullback h := - conjugateIsoEquiv ((mapPullbackAdj f).comp (mapPullbackAdj k)) - ((mapPullbackAdj h).comp (mapPullbackAdj g)) (mapIsoSquare sq) - -end BeckChevalleyTrans -end Over - -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] - [R.IsStableUnderComposition] - {X Y Z W : T} (h : X ⟶ Z) (f : X ⟶(Q) Y) (g : Z ⟶(Q) W) (k : Y ⟶ W) - (sq : CommSq h f.1 g.1 k) - -instance : MorphismProperty.HasOfPostcompProperty (C := T) ⊤ ⊤ where - of_postcomp := sorry - -/-- The Beck-Chevalley natural transformation -`pushforward g ⋙ pullback k ⟶ pullback h ⋙ pushforward f` constructed as a mate of -`pullbackMapTwoSquare`. -``` - R.Over ⊤ Z - pushforward g → R.Over ⊤ W - | | -pullback h | ↙ | pullback k - V V - R.Over ⊤ X - pushforward f → R.Over ⊤ Y -``` --/ ---pushforwardBeckChevalleySquare -def pushforwardPullbackTwoSquare : - TwoSquare (MorphismProperty.pushforward (P := R) (Q := Q) g) - (MorphismProperty.Over.pullback R ⊤ h) - (MorphismProperty.Over.pullback R ⊤ k) - (MorphismProperty.pushforward (P := R) (Q := Q) f) := - mateEquiv (MorphismProperty.pullbackPushforwardAdjunction R Q g) - (MorphismProperty.pullbackPushforwardAdjunction R Q f) - ((MorphismProperty.Over.pullbackComp _ _).inv ≫ - eqToHom (by rw! [sq.w]) ≫ - (MorphismProperty.Over.pullbackComp _ _).hom) - -- conjugateEquiv (mapPullbackAdj k |>.comp <| MorphismProperty.pullbackPushforwardAdjunction g) - -- (MorphismProperty.pullbackPushforwardAdjunction R Q f |>.comp <| - -- MorphismProperty.Over.mapPullbackAdj R ⊤ h) - -- (Over.pullbackMapTwoSquare h f.1 g.1 k sq) - --- /-- --- A variant of `pushforwardTwoSquare` involving `star` instead of `pullback`. --- -/ --- --pushforwardStarBeckChevalleySquare --- def starPushforwardTriangle [HasBinaryProducts C] [ExponentiableMorphism f] : --- star Y ⟶ star X ⋙ pushforward f := by --- let iso := (starPullbackIsoStar f).hom --- rw [← Functor.id_comp (star X)] at iso --- exact (mateEquiv Adjunction.id (adj f)) iso - --- /-- The conjugate isomorphism between the pushforwards along a commutative square. --- ``` --- Over X --.pushforward h -→ Over Z --- | | --- .pushforward f | ≅ | .pushforward g --- ↓ ↓ --- Over Y --.pushforward k -→ Over W --- ``` --- -/ --- def pushforwardIsoSquare [ExponentiableMorphism f] [ExponentiableMorphism g] --- [ExponentiableMorphism h] [ExponentiableMorphism k] : --- pushforward h ⋙ pushforward g ≅ pushforward f ⋙ pushforward k := --- conjugateIsoEquiv (adj g |>.comp <| adj h) (adj k |>.comp <| adj f) (pullbackIsoSquare h f g k sq) - --- end BeckChevalleyTrans - --- end Over - --- section BeckChevalleyComponents - --- variable {C : Type u} [Category.{v} C] - --- namespace IsPullback - --- /-- --- In a commutative cube diagram if the front, back and the right face are pullback squares then --- the the left face is also a pullback square. --- ``` --- P ---p₂------ X --- /| /| --- i₄ / | i₂ / | --- / | / | f₂ --- Q ----q₂----- Z | --- | | | | --- | W -f₁----- | - S --- q₁ | / | / --- | / i₁ | / i₃ --- |/ |/ --- Y ----g₁------ T --- ``` --- -/ --- theorem left_face_of_comm_cube {P W X Y Q Z S T : C} --- (p₁ : P ⟶ W) (p₂ : P ⟶ X) (f₁ : W ⟶ S) (f₂ : X ⟶ S) --- (q₁ : Q ⟶ Y) (q₂ : Q ⟶ Z) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) --- (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) (i₄ : P ⟶ Q) --- (sq_top : CommSq p₂ i₄ i₂ q₂) --- (sq_bot : CommSq f₁ i₁ i₃ g₁) --- (sq_left : CommSq i₄ p₁ q₁ i₁) --- (pb_back : IsPullback p₂ p₁ f₂ f₁) --- (pb_front : IsPullback q₂ q₁ g₂ g₁) --- (pb_right : IsPullback i₂ f₂ g₂ i₃) : --- IsPullback i₄ p₁ q₁ i₁ := by --- have paste_horiz_pb := paste_horiz pb_back pb_right --- rw [sq_top.w, sq_bot.w] at paste_horiz_pb --- exact of_right paste_horiz_pb sq_left.w pb_front - --- /-- --- In a commutative cube diagram if the front, the left and the right face are pullback squares then --- the the back face is also a pullback square. --- ``` --- P ---p₂------ X --- /| /| --- i₄ / | i₂ / | --- / | / | f₂ --- Q ----q₂----- Z | --- | | | | --- | W -f₁----- | - S --- q₁ | / | / --- | / i₁ | / i₃ --- |/ |/ --- Y ----g₁------ T --- ``` --- -/ --- theorem back_face_of_comm_cube {P W X Y Q Z S T : C} --- (p₁ : P ⟶ W) (p₂ : P ⟶ X) (f₁ : W ⟶ S) (f₂ : X ⟶ S) --- (q₁ : Q ⟶ Y) (q₂ : Q ⟶ Z) (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) --- (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) (i₄ : P ⟶ Q) --- (sq_top : CommSq p₂ i₄ i₂ q₂) --- (sq_bot : CommSq f₁ i₁ i₃ g₁) --- (sq_back : CommSq p₂ p₁ f₂ f₁) --- (pb_front : IsPullback q₂ q₁ g₂ g₁) --- (pb_left : IsPullback i₄ p₁ q₁ i₁) --- (pb_right : IsPullback i₂ f₂ g₂ i₃) : --- IsPullback p₂ p₁ f₂ f₁ := by --- have paste_horiz_pb := paste_horiz pb_left pb_front --- rw [← sq_top.w, ← sq_bot.w] at paste_horiz_pb --- exact of_right paste_horiz_pb sq_back.w pb_right - --- /-- The pullback comparison map `pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃` between two --- pullback squares is an isomorphism if `i₁` is an isomorphism and one of the --- connecting morphisms is an isomorphism. -/ --- theorem pullback.map_isIso_of_pullback_right_of_comm_cube {W X Y Z S T : C} --- (f₁ : W ⟶ S) (f₂ : X ⟶ S) [HasPullback f₁ f₂] --- (g₁ : Y ⟶ T) (g₂ : Z ⟶ T) [HasPullback g₁ g₂] --- (i₁ : W ⟶ Y) (i₂ : X ⟶ Z) (i₃ : S ⟶ T) --- (sq_bot : CommSq f₁ i₁ i₃ g₁) --- [IsIso i₁] (pb_right : IsPullback i₂ f₂ g₂ i₃) : --- IsIso (pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ sq_bot.w pb_right.w.symm) := by --- let m := pullback.map f₁ f₂ g₁ g₂ i₁ i₂ i₃ sq_bot.w pb_right.w.symm --- have sq_top : CommSq (pullback.snd f₁ f₂) m i₂ (pullback.snd g₁ g₂) := by --- aesop --- have sq_left : CommSq m (pullback.fst f₁ f₂) (pullback.fst g₁ g₂) i₁ := by --- aesop --- let pb' : IsPullback m (pullback.fst f₁ f₂) (pullback.fst g₁ g₂) i₁ := by --- apply IsPullback.left_face_of_comm_cube (sq_top := sq_top) (sq_bot := sq_bot) --- (sq_left := sq_left) (pb_back := (IsPullback.of_hasPullback f₁ f₂).flip) --- (pb_front := (IsPullback.of_hasPullback g₁ g₂).flip) --- (pb_right := pb_right) --- have is_iso : IsIso m := IsPullback.isIso_fst_of_isIso pb' --- exact is_iso - --- end IsPullback - --- variable [HasPullbacks C] - --- variable {X Y Z W : C} {h : X ⟶ Z} {f : X ⟶ Y} {g : Z ⟶ W} {k : Y ⟶ W} --- (sq : CommSq h f g k) (A : Over Y) - --- open IsPullback Over - --- theorem mapPullbackAdj.counit_app_left : --- ((mapPullbackAdj f).counit.app A).left = pullback.fst _ _ := by --- simp only [mapPullbackAdj_counit_app, homMk_left] - --- @[simp] --- theorem pullbackMapTwoSquare_app : --- (pullbackMapTwoSquare h f g k sq).app A = --- Over.homMk (pullback.map _ _ (A.hom ≫ k) _ _ h k (id_comp _).symm sq.w.symm) (by aesop) := by --- ext --- simp only [homMk_left, pullbackMapTwoSquare, mapIsoSquare] --- aesop - --- theorem forget_map_pullbackMapTwoSquare : --- (forget Z).map ((pullbackMapTwoSquare h f g k sq).app A) = --- pullback.map _ _ _ _ (𝟙 _) h k (id_comp _).symm sq.w.symm := by --- simp only [forget_map, pullbackMapTwoSquare_app, homMk_left] - --- theorem isIso_forgetMappullbackMapTwoSquare_of_isPullback (pb : IsPullback h f g k) : --- IsIso ((forget Z).map ((pullbackMapTwoSquare h f g k pb.toCommSq).app A)) := by --- rw [forget_map_pullbackMapTwoSquare (sq:= pb.toCommSq)] --- let paste_horiz_pb := paste_horiz (IsPullback.of_hasPullback f A.hom) pb --- apply pullback.map_isIso_of_pullback_right_of_comm_cube --- assumption' --- aesop - --- /-- The pullback Beck-Chevalley natural transformation of a pullback square is an isomorphism. -/ --- instance pullbackMapTwoSquare_of_isPullback_isIso (pb : IsPullback h f g k) : --- IsIso (pullbackMapTwoSquare h f g k pb.toCommSq) := by --- apply (config := { allowSynthFailures:= true}) NatIso.isIso_of_isIso_app --- intro A --- have := isIso_forgetMappullbackMapTwoSquare_of_isPullback A pb --- exact ReflectsIsomorphisms.reflects (forget Z) --- ((pullbackMapTwoSquare h f g k pb.toCommSq).app A) - --- /-- The pullback-map exchange isomorphism. -/ --- def pullbackMapIsoSquare (pb : IsPullback h f g k) : --- pullback f ⋙ map h ≅ Over.map k ⋙ Over.pullback g := by --- refine @asIso _ _ _ _ (pullbackMapTwoSquare h f g k pb.toCommSq) ?_ --- exact pullbackMapTwoSquare_of_isPullback_isIso pb - --- /-- The functor Beck-Chevalley natural transformation of a pullback square is an isomorphism. -/ --- instance pushforwardPullbackTwoSquare_of_isPullback_isIso (pb : IsPullback h f g k) --- [ExponentiableMorphism f] [ExponentiableMorphism g] : --- IsIso (pushforwardPullbackTwoSquare h f g k pb.toCommSq) := by --- have := pullbackMapTwoSquare_of_isPullback_isIso pb --- apply conjugateEquiv_iso - --- /-- The pullback-pushforward exchange isomorphism. -/ --- def pushforwardPullbackIsoSquare (pb : IsPullback h f g k) --- [ExponentiableMorphism f] [ExponentiableMorphism g] : --- pushforward g ⋙ pullback k ≅ pullback h ⋙ pushforward f := by --- refine @asIso _ _ _ _ (pushforwardPullbackTwoSquare h f g k pb.toCommSq) ?_ --- exact pushforwardPullbackTwoSquare_of_isPullback_isIso pb - --- end BeckChevalleyComponents - --- end CategoryTheory - --- end diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 97c00436..422ea497 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -22,6 +22,19 @@ variable {C : Type u} [Category.{v} C] namespace MorphismProperty +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])) + /-- The Beck-Chevalley natural transformation `pushforward g ⋙ pullback k ⟶ pullback h ⋙ pushforward f` constructed as a mate of `pullbackMapTwoSquare`. @@ -164,13 +177,14 @@ R.Over ⊤ I ----> R.Over ⊤ E ----> R.Over ⊤ B -/ 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' := + 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 : Over.pullback R ⊤ i' ⋙ Over.pullback R ⊤ ρ ⟶ Over.pullback R ⊤ i := - (cellLeftIso).hom - let cellMid := push - sorry + 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 cellMid := pushforwardPullbackTwoSquare (R := R) (Q := Q) ρ p p' (𝟙 _) (by simp [← hp]) + Functor.whiskerLeft (partialRightAdjoint i' p') (Over.pullbackId R ⊤ B).inv ≫ + cellLeft.hComp cellMid end PolynomialPartialAdjunction @@ -454,21 +468,28 @@ P.p\ / Q.p ↘ ↙ B ``` -induces a natural transformation `Q.functor ⟶ P.functor ` obtained by pasting the following 2-cells +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 V ‖ R.Over ⊤ I ----> R.Over ⊤ E ----> R.Over ⊤ B -----> R.Over ⊤ O - P.p.1 + 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) - (h : P.p.1 = ρ ≫ Q.p.1) : Q.functor ⟶ P.functor := sorry + (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 end MvPoly @@ -521,9 +542,10 @@ variable [HasTerminal C] 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 - let p : E ⟶(R) B := ⟨ P.p, P.morphismProperty ⟩ - convert_to HasPullback A p.1 + convert_to HasPullback A (morphismProperty' P).1 apply MorphismProperty.instHasPullbackFstHomOfHasPullbacks instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback P.p A := @@ -543,7 +565,7 @@ 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 := ⟨P.p, P.morphismProperty⟩ + p := morphismProperty' P o := object B def functor (P : UvPoly R E B) : C ⥤ C := @@ -598,33 +620,34 @@ open TwoSquare /-- A commutative triangle ``` - ρ -E -------> F - \ / -p \ / q - ↘ ↙ - B + 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 +induces a natural transformation `Q.functor ⟶ P.functor ` obtained by pasting the following 2-cells ``` - Q.p.1 -C --- > C/F ----> C/B -----> C -| | | | -| ↙ | ρ* ≅ | = | -| v v | -C --- > C/E ----> C/B ----> C - P.p.1 + 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 cellLeft := (Over.starPullbackIsoStar ρ).hom - sorry --by - -- have sq : CommSq ρ P.p.1 Q.p.1 (𝟙 _) := by simp [h] - -- let cellMid := (pushforwardPullbackTwoSquare ρ P.p Q.p (𝟙 _) sq) - -- let cellLeftMidPasted := TwoSquare.whiskerRight (cellLeft ≫ₕ cellMid) (Over.pullbackId).inv - -- simpa using (cellLeftMidPasted ≫ₕ (vId (forget B))) + (toOverTerminal).whiskerLeft (Functor.whiskerRight + (MvPoly.verticalNatTrans P.mvPoly Q.mvPoly ρ (terminal.hom_ext _ _) h (terminal.hom_ext _ _)) + fromOverTerminal) /-- A cartesian map of polynomials ``` @@ -642,7 +665,7 @@ induces a natural transformation between their associated functors obtained by p Q.p C --- > C/F ----> C/D -----> C | | | | -| ↗ | φ* ≅ | δ* ↗ | +| ↗ | φ* ≅ | δ* ↗ | | v v | C --- > C/E ----> C/B ----> C P.p From 35316d2565e0b5db889b0f2d631c497bdd04e45d Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 29 Sep 2025 23:23:56 -0400 Subject: [PATCH 13/59] cartesianNatTrans --- .../ForMathlib/CategoryTheory/Polynomial.lean | 398 ++++++++++++++---- 1 file changed, 317 insertions(+), 81 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 422ea497..987792ee 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -22,6 +22,9 @@ 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) @@ -35,9 +38,91 @@ noncomputable def Over.pullbackId (P Q : MorphismProperty C) (X) NatIso.ofComponents (fun X ↦ Over.isoMk (asIso (pullback.fst X.hom (𝟙 _))) (by simp [pullback.condition])) -/-- The Beck-Chevalley natural transformation -`pushforward g ⋙ pullback k ⟶ pullback h ⋙ pushforward f` constructed as a mate of -`pullbackMapTwoSquare`. +/-- 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 | | @@ -45,21 +130,53 @@ 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) - (sq : h ≫ g.1 = f.1 ≫ k) : - TwoSquare (MorphismProperty.pushforward (P := R) (Q := Q) g) - (MorphismProperty.Over.pullback R ⊤ h) - (MorphismProperty.Over.pullback R ⊤ k) - (MorphismProperty.pushforward (P := R) (Q := Q) f) := - mateEquiv (MorphismProperty.pullbackPushforwardAdjunction R Q g) - (MorphismProperty.pullbackPushforwardAdjunction R Q f) - ((MorphismProperty.Over.pullbackComp _ _).inv ≫ - eqToHom (by rw! [sq]) ≫ - (MorphismProperty.Over.pullbackComp _ _).hom) + (pb : IsPullback h f.1 g.1 k) : IsIso (pushforwardPullbackTwoSquare (R := R) h f g k pb.w) := + sorry namespace PolynomialPartialAdjunction @@ -166,11 +283,11 @@ obtained by pasting the following 2-cells ``` pullback i' pushforward p' R.Over ⊤ I ----> R.Over ⊤ E' ----> R.Over ⊤ B - ‖ | | - ‖ | | - ‖ ≅ |ρ* ↙ | - ‖ | | - ‖ V V + ‖ | ‖ + ‖ | ‖ + ‖ ↙ |ρ* ↙ ‖ + ‖ | ‖ + ‖ V ‖ R.Over ⊤ I ----> R.Over ⊤ E ----> R.Over ⊤ B pullback i pushforward p ``` @@ -182,9 +299,9 @@ def partialRightAdjointMap {E' : T} (i' : E' ⟶ I) (p' : E' ⟶(Q) B) (ρ) (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 cellMid := pushforwardPullbackTwoSquare (R := R) (Q := Q) ρ p p' (𝟙 _) (by simp [← hp]) + let cellRight := pushforwardPullbackTwoSquare (R := R) (Q := Q) ρ p p' (𝟙 _) (by simp [← hp]) Functor.whiskerLeft (partialRightAdjoint i' p') (Over.pullbackId R ⊤ B).inv ≫ - cellLeft.hComp cellMid + cellLeft.hComp cellRight end PolynomialPartialAdjunction @@ -298,15 +415,16 @@ structure MvPoly (R : MorphismProperty C) (H : MorphismProperty C) (I O E B : C) namespace MvPoly -instance : (⊤ : MorphismProperty C).HasOfPostcompProperty ⊤ where - of_postcomp := by simp - 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] @@ -446,9 +564,6 @@ lemma eta (pair : Γ ⟶ (P @ X).toComma) : mk (fst pair) (by simp) (snd pair) = end Equiv -instance (P : MvPoly R H I O E B) : Limits.PreservesLimitsOfShape WalkingCospan - (MorphismProperty.Over.map ⊤ P.o.2) := by sorry - instance (P : MvPoly R H I O E B) : Limits.PreservesLimitsOfShape WalkingCospan (MvPoly.functor P) := by dsimp [functor] @@ -473,24 +588,123 @@ 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 V ‖ + ‖ | ‖ ‖ + ‖ | ‖ ‖ + ‖ ↙ |ρ* ↙ ‖ = ‖ + ‖ | ‖ ‖ + ‖ 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 := + (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 + +theorem _root_.CategoryTheory.NatTrans.IsCartesian.comp' {J : Type*} [Category J] + {F G H : J ⥤ C} {α : F ⟶ G} {β : G ⟶ H} (hα : α.IsCartesian) (hβ : β.IsCartesian) : + (α ≫ β).IsCartesian := inferInstance + +theorem _root_.CategoryTheory.NatTrans.IsCartesian.of_isIso' {J : Type*} [Category J] + {F G : J ⥤ C} (α : F ⟶ G) [IsIso α] : + α.IsCartesian := inferInstance + +-- TODO: use Sina's Poly ForMathlib files, not the `clan` branch of Mathlib. +-- JH changed IsCartesian to an instance, which proves to be difficult to work with. +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] + 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] + -- apply IsCartesian.comp'; apply IsCartesian.of_isIso' + -- apply IsCartesian.comp' + -- · apply IsCartesian.whiskerRight + -- · apply isCartesian_mapPullbackAdj_counit + -- . apply isCartesian_of_isIso + sorry + infer_instance + end MvPoly /-- `P : UvPoly R E B` is the type of signatures for polynomial functors @@ -645,54 +859,46 @@ C --- ≅ ---> R.Over ⊤ 1 ----> R.Over ⊤ 1 --- ≅ ---> C -/ 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 := - (toOverTerminal).whiskerLeft (Functor.whiskerRight - (MvPoly.verticalNatTrans P.mvPoly Q.mvPoly ρ (terminal.hom_ext _ _) h (terminal.hom_ext _ _)) - fromOverTerminal) + let mv : Q.mvPoly.functor ⟶ P.mvPoly.functor := + MvPoly.verticalNatTrans P.mvPoly Q.mvPoly ρ (terminal.hom_ext ..) h (terminal.hom_ext ..) + (toOverTerminal).whiskerLeft (Functor.whiskerRight mv fromOverTerminal) + +open TwoSquare /-- A cartesian map of polynomials ``` - P.p - E --------> B - | | - φ | | δ - v v - F --------> D - Q.p + φ + 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 ``` - Q.p -C --- > C/F ----> C/D -----> C -| | | | -| ↗ | φ* ≅ | δ* ↗ | -| v v | -C --- > C/E ----> C/B ----> C + P'.p +C --- > C/E' ----> C/B' -----> C +‖ | | ‖ +‖ ↗ | φ* ≅ | δ* ↗ ‖ +‖ v v ‖ +C --- > C/E -----> C/B -----> C P.p ``` -/ -def cartesianNatTrans {D F : C} (P : UvPoly R E B) (Q : UvPoly R F D) - (δ : B ⟶ D) (φ : E ⟶ F) (pb : IsPullback P.p φ δ Q.p) : P.functor ⟶ Q.functor := - sorry - -- let cellLeft : TwoSquare (𝟭 C) (Over.star F) (Over.star E) (pullback φ) := - -- (Over.starPullbackIsoStar φ).inv - -- let cellMid : TwoSquare (pullback φ) (pushforward Q.p) (pushforward P.p) (pullback δ) := - -- (pushforwardPullbackIsoSquare pb.flip).inv - -- let cellRight : TwoSquare (pullback δ) (forget D) (forget B) (𝟭 C) := - -- pullbackForgetTwoSquare δ - -- let := cellLeft ≫ᵥ cellMid ≫ᵥ cellRight - -- this +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 δ φ (terminal.hom_ext ..) pb (terminal.hom_ext ..) + (toOverTerminal).whiskerLeft (Functor.whiskerRight mv fromOverTerminal) 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 - sorry - -- simp [cartesianNatTrans] - -- infer_instance - + (δ : B ⟶ D) (φ : E ⟶ F) (pb : IsPullback φ P.p Q.p δ) : + (cartesianNatTrans P Q δ φ pb).IsCartesian := -- (isCartesian_of_isIso _).vComp <| -- (isCartesian_of_isIso _).vComp <| -- isCartesian_pullbackForgetTwoSquare _ + sorry /-- 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 @@ -975,20 +1181,21 @@ theorem mk_comp_left {Δ} (b : Γ ⟶ B) (x : pullback b P.p ⟶ X) (σ: Δ ⟶ 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.1) --- (x : pb ⟶ X) (e : E ⟶ E') (b : B ⟶ B') --- (hp : IsPullback P.p.1 e b P'.p.1) : --- Equiv.mk' y H x ≫ (P.cartesianNatTrans P' b e hp).app X = --- Equiv.mk' P' X (y ≫ b) (H.paste_vert hp) x := by --- have : fst P' X (Equiv.mk' P X y H x ≫ (P.cartesianNatTrans P' b e hp).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 +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 @@ -1170,6 +1377,35 @@ lemma comp_mk {Δ} (σ : Δ ⟶ Γ) (b : Γ ⟶ B) (e : Γ ⟶ E) (he : e ≫ P. 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) := From 54191f749559d504eb706def20c6b13c42d740d5 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 30 Sep 2025 00:19:45 -0400 Subject: [PATCH 14/59] refactor: interpretation --- .../ForMathlib/CategoryTheory/Polynomial.lean | 49 ++-- HoTTLean/Model/Interpretation.lean | 239 +++++++++--------- HoTTLean/Model/NaturalModel.lean | 2 - HoTTLean/Model/UHom.lean | 2 +- 4 files changed, 150 insertions(+), 142 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 987792ee..4e5f4d44 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -722,7 +722,7 @@ Therefore it will typically be used with the following instances `[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 `[HasTerminal C]`. + 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]`. @@ -751,7 +751,9 @@ section variable {R : MorphismProperty C} {E B : C} -variable [HasTerminal C] +variable [ChosenTerminal C] + +open ChosenTerminal variable [R.IsStableUnderComposition] [R.HasPullbacks] [R.IsStableUnderBaseChange] [R.HasObjects] [R.IsStableUnderPushforward R] [R.HasPushforwards R] @@ -765,19 +767,19 @@ instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback A P.p := by instance (P : UvPoly R E B) {Γ : C} (A : Γ ⟶ B) : HasPullback P.p A := hasPullback_symmetry _ _ -def object (X : C) : X ⟶(R) ⊤_ C := - ⟨terminal.from X, HasObjects.obj_mem _ terminalIsTerminal⟩ +def object (X : C) : X ⟶(R) (𝟭_ C) := + ⟨ isTerminal.from X, HasObjects.obj_mem _ ChosenTerminal.isTerminal⟩ @[simp] -abbrev toOverTerminal : C ⥤ R.Over ⊤ (⊤_ C) := - (equivalenceOfHasObjects R terminalIsTerminal).inverse +abbrev toOverTerminal : C ⥤ R.Over ⊤ (𝟭_ C) := + (equivalenceOfHasObjects R isTerminal).inverse @[simp] -abbrev fromOverTerminal : R.Over ⊤ (⊤_ C) ⥤ C := - (equivalenceOfHasObjects R terminalIsTerminal).functor +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 (P : UvPoly R E B) : MvPoly R R (𝟭_ C) (𝟭_ C) E B where i := object E p := morphismProperty' P o := object B @@ -788,12 +790,12 @@ def functor (P : UvPoly R E B) : C ⥤ C := fromOverTerminal /-- The action of a univariate polynomial on objects. -/ -def apply [HasTerminal C] (P : UvPoly R E B) : C → C := P.functor.obj +def apply [ChosenTerminal C] (P : UvPoly R E B) : C → C := P.functor.obj @[inherit_doc] infix:90 " @ " => apply -instance [HasTerminal C] (P : UvPoly R E B) : +instance [ChosenTerminal C] (P : UvPoly R E B) : Limits.PreservesLimitsOfShape WalkingCospan P.functor := by unfold functor infer_instance @@ -860,7 +862,7 @@ C --- ≅ ---> R.Over ⊤ 1 ----> R.Over ⊤ 1 --- ≅ ---> C 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 ρ (terminal.hom_ext ..) h (terminal.hom_ext ..) + MvPoly.verticalNatTrans P.mvPoly Q.mvPoly ρ (isTerminal.hom_ext ..) h (isTerminal.hom_ext ..) (toOverTerminal).whiskerLeft (Functor.whiskerRight mv fromOverTerminal) open TwoSquare @@ -889,7 +891,7 @@ C --- > C/E -----> C/B -----> C -/ 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 δ φ (terminal.hom_ext ..) pb (terminal.hom_ext ..) + let mv := P.mvPoly.cartesianNatTrans P'.mvPoly δ φ (isTerminal.hom_ext ..) pb (isTerminal.hom_ext ..) (toOverTerminal).whiskerLeft (Functor.whiskerRight mv fromOverTerminal) theorem isCartesian_cartesianNatTrans {D F : C} (P : UvPoly R E B) (Q : UvPoly R F D) @@ -967,10 +969,11 @@ namespace Equiv variable {P : UvPoly R E B} {Γ X Y : C} -/-- Convert the morphism `pair` into a morphism in the over category `Over (⊤_ C)` -/ +/-- Convert the morphism `pair` into a morphism in the over category `Over (𝟭_ C)` -/ @[simp] -abbrev homMk (pair : Γ ⟶ P @ X) : Over.mk (terminal.from Γ) ⟶ - ((toOverTerminal ⋙ MvPoly.functor P.mvPoly).obj X).toComma := Over.homMk pair +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 @@ -1007,16 +1010,16 @@ def snd' (pair : Γ ⟶ P @ X) {pb f g} (H : IsPullback (P := pb) f g (fst 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)` -/ +/-- 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 + 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 (terminal.from Γ)) - (Over.mk b) (by congr; apply terminal.hom_ext) (mkAux b x)).left + (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) @@ -1065,8 +1068,8 @@ lemma snd'_eq_snd' (pair : Γ ⟶ P @ X) {pb f g} (H : IsPullback (P := pb) f g @[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 (terminal.from Γ)) - (Over.mk b) (by congr; apply terminal.hom_ext) (mkAux b x) + 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 @@ -1125,7 +1128,7 @@ theorem snd_comp_right (pair : Γ ⟶ P @ X) (f : X ⟶ Y) : snd (pair ≫ P.fun @[simp] lemma eta (pair : Γ ⟶ P @ X) : mk (fst pair) (snd pair) = pair := by - have := MvPoly.Equiv.eta (P := P.mvPoly) (Γ := Over.mk (terminal.from Γ)) (homMk pair) + have := MvPoly.Equiv.eta (P := P.mvPoly) (Γ := Over.mk (isTerminal.from Γ)) (homMk pair) exact congr_arg CommaMorphism.left this @[simp] diff --git a/HoTTLean/Model/Interpretation.lean b/HoTTLean/Model/Interpretation.lean index bd47dbc7..4adc0f79 100644 --- a/HoTTLean/Model/Interpretation.lean +++ b/HoTTLean/Model/Interpretation.lean @@ -19,13 +19,18 @@ noncomputable section namespace NaturalModel.Universe open SynthLean -variable {𝒞 : Type u} [SmallCategory 𝒞] [ChosenTerminal 𝒞] +variable {𝒞 : Type u} [Category 𝒞] + {R : MorphismProperty 𝒞} (M : Universe R) + [R.HasPullbacks] [R.IsStableUnderBaseChange] +variable [ChosenTerminal 𝒞] [R.HasObjects] [R.IsMultiplicative] + [R.HasPushforwards R] [R.IsStableUnderPushforward R] + open ChosenTerminal /-! ## Universe level bound helpers -/ section univBounds -variable {s : UHomSeq 𝒞} (slen : univMax ≤ s.length) +variable {s : UHomSeq R} (slen : univMax ≤ s.length) variable {χ : Type*} {E : Axioms χ} {Γ : Ctx χ} {A B t u : Expr χ} {l : Nat} include slen @@ -53,13 +58,13 @@ where `Γ` is a prefix of `Γ'`. It witnesses a sequence of context extension operations in `s` that built `Γ'` on top of `Γ`. We write `Γ ≤ Γ'`. -/ -inductive ExtSeq (s : UHomSeq 𝒞) (Γ : 𝒞) : 𝒞 → Type u where +inductive ExtSeq (s : UHomSeq R) (Γ : 𝒞) : 𝒞 → Type u where | nil : s.ExtSeq Γ Γ - | snoc {Γ'} {l : Nat} (d : s.ExtSeq Γ Γ') (llen : l < s.length + 1) (A : y(Γ') ⟶ s[l].Ty) : + | snoc {Γ'} {l : Nat} (d : s.ExtSeq Γ Γ') (llen : l < s.length + 1) (A : Γ' ⟶ s[l].Ty) : s.ExtSeq Γ (s[l].ext A) namespace ExtSeq -variable {s : UHomSeq 𝒞} +variable {s : UHomSeq R} -- Q : What would a `Lookup` `Prop` family for `ExtSeq` look like? -- The purpose of adding it would be to totalize `var`, `tp`, and other functions. @@ -104,7 +109,7 @@ def substWk {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) : s.ExtSeq Γ Γ' → Σ (Δ' : | .nil => ⟨Δ, .nil, σ⟩ | snoc (l := l) d llen A => let ⟨Δ, d, σ⟩ := d.substWk σ - ⟨s[l].ext (ym(σ) ≫ A), d.snoc llen (ym(σ) ≫ A), s[l].substWk σ A⟩ + ⟨s[l].ext ((σ) ≫ A), d.snoc llen ((σ) ≫ A), s[l].substWk σ A⟩ @[simp] theorem substWk_length {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : s.ExtSeq Γ Γ') : @@ -118,25 +123,25 @@ theorem substWk_disp {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : s.ExtSeq Γ Γ') : /-- `Γ.Aₖ.….A₀ ⊢ vₙ : Aₙ[↑ⁿ⁺¹]` -/ protected def var {Γ Γ' : 𝒞} {l : Nat} (llen : l < s.length + 1) : - s.ExtSeq Γ Γ' → ℕ → Part (y(Γ') ⟶ s[l].Tm) + s.ExtSeq Γ Γ' → ℕ → Part (Γ' ⟶ s[l].Tm) | .nil, _ => .none | snoc (l := l') _ _ A, 0 => Part.assert (l' = l) fun l'l => return l'l ▸ s[l'].var A | snoc (l := l') d _ A, n+1 => do let v ← d.var llen n - return ym(s[l'].disp A) ≫ v + return (s[l'].disp A) ≫ v /-- `Γ.Aₖ.….A₀ ⊢ Aₙ[↑ⁿ⁺¹]` -/ protected def tp {Γ Γ' : 𝒞} {l : Nat} (llen : l < s.length + 1) : - s.ExtSeq Γ Γ' → ℕ → Part (y(Γ') ⟶ s[l].Ty) + s.ExtSeq Γ Γ' → ℕ → Part (Γ' ⟶ s[l].Ty) | .nil, _ => .none | snoc (l := l') _ _ A, 0 => Part.assert (l' = l) fun l'l => - return l'l ▸ ym(s[l'].disp A) ≫ A + return l'l ▸ (s[l'].disp A) ≫ A | snoc (l := l') d _ A, n+1 => do let v ← d.tp llen n - return ym(s[l'].disp A) ≫ v + return (s[l'].disp A) ≫ v theorem var_tp {Γ Γ' : 𝒞} {l : Nat} (d : s.ExtSeq Γ Γ') (llen : l < s.length + 1) (n : ℕ) : (d.var llen n).map (· ≫ s[l].tp) = d.tp llen n := by @@ -165,19 +170,19 @@ theorem var_eq_of_lt_length {l i} {llen : l < s.length + 1} {sΓ sΓ' sΓ'' : theorem var_append_add_length {l i} {llen : l < s.length + 1} {sΓ sΓ' sΓ'' : 𝒞} (d : s.ExtSeq sΓ sΓ') (e : s.ExtSeq sΓ' sΓ'') : - (d.append e).var llen (i + e.length) = (d.var llen i).map (ym(e.disp) ≫ ·) := by + (d.append e).var llen (i + e.length) = (d.var llen i).map ((e.disp) ≫ ·) := by induction e <;> (simp [ExtSeq.var, Part.bind_some_eq_map, Part.map_map, *]; rfl) theorem var_substWk_add_length {l i} {llen : l < s.length + 1} {sΔ sΔ' sΓ sΓ' : 𝒞} (d : s.ExtSeq sΔ sΔ') (σ : sΔ' ⟶ sΓ) (e : s.ExtSeq sΓ sΓ') : let ⟨_, d', _⟩ := e.substWk σ - (d.append d').var llen (i + e.length) = (d.var llen i).map (ym(d'.disp) ≫ ·) := by + (d.append d').var llen (i + e.length) = (d.var llen i).map ((d'.disp) ≫ ·) := by rw [← e.substWk_length σ] apply var_append_add_length theorem var_substWk_of_lt_length {l i} {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : s.ExtSeq Γ Γ') (llen : l < s.length + 1) {st} (st_mem : st ∈ d.var llen i) : - i < d.length → ym((substWk σ d).2.2) ≫ st ∈ (substWk σ d).2.1.var llen i := by + i < d.length → ((substWk σ d).2.2) ≫ st ∈ (substWk σ d).2.1.var llen i := by induction d generalizing i with | nil => simp | snoc _ _ _ ih => @@ -193,7 +198,7 @@ theorem var_substWk_of_lt_length {l i} {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : simp_part at st_mem ⊢ obtain ⟨a, amem, rfl⟩ := st_mem refine ⟨_, ih amem h, ?_⟩ - simp only [← Functor.map_comp_assoc] + simp only [← Category.assoc] simp [NaturalModel.Universe.substWk_disp] end ExtSeq @@ -206,16 +211,16 @@ i.e., one of the form `1.Aₙ₋₁.….A₀`, together with the extension sequence `[Aₙ₋₁ :: … :: A₀]`. This kind of object can be destructured. -/ -def CObj (s : UHomSeq 𝒞) : Type u := Σ Γ : 𝒞, s.ExtSeq (𝟭_ 𝒞) Γ +def CObj (s : UHomSeq R) : Type u := Σ Γ : 𝒞, s.ExtSeq (𝟭_ 𝒞) Γ -def nilCObj (s : UHomSeq 𝒞) : s.CObj := +def nilCObj (s : UHomSeq R) : s.CObj := ⟨𝟭_ 𝒞, .nil⟩ namespace CObj -variable {s : UHomSeq 𝒞} +variable {s : UHomSeq R} @[simps] -def snoc {l : Nat} (Γ : s.CObj) (llen : l < s.length + 1) (A : y(Γ.1) ⟶ s[l].Ty) : s.CObj := +def snoc {l : Nat} (Γ : s.CObj) (llen : l < s.length + 1) (A : Γ.1 ⟶ s[l].Ty) : s.CObj := ⟨s[l].ext A, Γ.2.snoc llen A⟩ @[simps] @@ -227,7 +232,7 @@ theorem append_nil (Γ : s.CObj) : Γ.append .nil = Γ := rfl @[simp] theorem append_snoc {sΓ' : 𝒞} {l} (Γ : s.CObj) (d : s.ExtSeq Γ.1 sΓ') - (llen : l < s.length + 1) (A : y(sΓ') ⟶ s[l].Ty) : + (llen : l < s.length + 1) (A : (sΓ') ⟶ s[l].Ty) : Γ.append (d.snoc llen A) = (Γ.append d).snoc llen A := rfl def substWk {sΓ sΓ' : 𝒞} (Δ : s.CObj) (σ : Δ.1 ⟶ sΓ) (d : s.ExtSeq sΓ sΓ') : @@ -240,17 +245,17 @@ theorem substWk_nil {sΓ : 𝒞} (Δ : s.CObj) (σ : Δ.1 ⟶ sΓ) : Δ.substWk σ .nil = ⟨Δ, σ⟩ := rfl theorem substWk_snoc {sΓ sΓ' : 𝒞} {l} (Δ : s.CObj) (σ : Δ.1 ⟶ sΓ) (d : s.ExtSeq sΓ sΓ') - (llen : l < s.length + 1) (A : y(sΓ') ⟶ s[l].Ty) : + (llen : l < s.length + 1) (A : (sΓ') ⟶ s[l].Ty) : Δ.substWk σ (d.snoc llen A) = let ⟨Δ', σ'⟩ := Δ.substWk σ d - ⟨Δ'.snoc llen (ym(σ') ≫ A), s[l].substWk σ' A⟩ := rfl + ⟨Δ'.snoc llen ((σ') ≫ A), s[l].substWk σ' A⟩ := rfl protected def var {l : Nat} (Γ : s.CObj) (llen : l < s.length + 1) (i : ℕ) : - Part (y(Γ.1) ⟶ s[l].Tm) := + Part (Γ.1 ⟶ s[l].Tm) := Γ.2.var llen i protected def tp {l : Nat} (Γ : s.CObj) (llen : l < s.length + 1) (i : ℕ) : - Part (y(Γ.1) ⟶ s[l].Ty) := + Part (Γ.1 ⟶ s[l].Ty) := Γ.2.tp llen i @[simp] @@ -263,7 +268,7 @@ theorem mem_var_zero {Γ : s.CObj} {l' l'len A l} {llen : l < s.length + 1} {x} @[simp] theorem mem_var_succ {Γ : s.CObj} {l' l'len A l i} {llen : l < s.length + 1} {x} : x ∈ (Γ.snoc (l := l') l'len A).var llen (i+1) ↔ - ∃ a ∈ Γ.var llen i, x = ym(s[l'].disp A) ≫ a := by + ∃ a ∈ Γ.var llen i, x = (s[l'].disp A) ≫ a := by dsimp only [UHomSeq.CObj.var, UHomSeq.CObj.snoc, UHomSeq.ExtSeq.var] simp_part @@ -278,14 +283,14 @@ end UHomSeq /-- An interpretation of a signature consists of a semantic term for each named axiom. This is the semantic equivalent of `Axioms χ`. -/ -structure Interpretation (χ : Type*) (s : UHomSeq 𝒞) where +structure Interpretation (χ : Type*) (s : UHomSeq R) where ax (c : χ) (l : Nat) (_ : l < s.length + 1 := by get_elem_tactic) : - Option (y(𝟭_ 𝒞) ⟶ s[l].Tm) + Option ((𝟭_ 𝒞) ⟶ s[l].Tm) -- We cannot state well-formedness yet: that needs `ofType`. namespace Interpretation -variable {s : UHomSeq 𝒞} {χ : Type*} (I : Interpretation χ s) +variable {s : UHomSeq R} {χ : Type*} (I : Interpretation χ s) variable [s.PiSeq] [s.SigSeq] [s.IdSeq] mutual @@ -293,7 +298,7 @@ mutual (that would be induction-recursion or something like it), thus the context must be an *input*. -/ def ofType (Γ : s.CObj) (l : Nat) : - Expr χ → (_ : l < s.length + 1 := by get_elem_tactic) → Part (y(Γ.1) ⟶ s[l].Ty) + Expr χ → (_ : l < s.length + 1 := by get_elem_tactic) → Part (Γ.1 ⟶ s[l].Ty) | .pi i j A B, _ => Part.assert (l = max i j) fun lij => do have ilen : i < s.length + 1 := by omega @@ -307,7 +312,7 @@ def ofType (Γ : s.CObj) (l : Nat) : have jlen : j < s.length + 1 := by omega let A ← ofType Γ i A let B ← ofType (Γ.snoc ilen A) j B - return lij ▸ s.mkSig ilen jlen A B + return lij ▸ (s.polymorphicSigma ilen jlen).mkSig A B | .Id _ A a0 a1, llen => do let A ← ofType Γ l A let a0 ← ofTerm Γ l a0 @@ -326,10 +331,10 @@ def ofType (Γ : s.CObj) (l : Nat) : | _, _ => .none def ofTerm (Γ : s.CObj) (l : Nat) : - Expr χ → (_ : l < s.length + 1 := by get_elem_tactic) → Part (y(Γ.1) ⟶ s[l].Tm) + Expr χ → (_ : l < s.length + 1 := by get_elem_tactic) → Part (Γ.1 ⟶ s[l].Tm) | .ax c _, llen => do let some sc := I.ax c l | Part.assert False nofun - return isTerminal_yUnit.from y(Γ.1) ≫ sc + return isTerminal.from Γ.1 ≫ sc | .bvar i, llen => Γ.var llen i | .lam i j A e, _ => do Part.assert (l = max i j) fun lij => do @@ -352,23 +357,23 @@ def ofTerm (Γ : s.CObj) (l : Nat) : let t ← ofTerm Γ i t let B ← ofType (Γ.snoc ilen (t ≫ s[i].tp)) j B let u ← ofTerm Γ j u - Part.assert (u ≫ s[j].tp = ym(s[i].sec _ t rfl) ≫ B) fun u_tp => - return lij ▸ s.mkPair ilen jlen (t ≫ s[i].tp) B t rfl u u_tp + Part.assert (u ≫ s[j].tp = (s[i].sec _ t rfl) ≫ B) fun u_tp => + return lij ▸ (s.polymorphicSigma ilen jlen).mkPair (t ≫ s[i].tp) B t rfl u u_tp | .fst _ j A B p, llen => do Part.assert (j < s.length + 1) fun jlen => do -- RB was so right let A ← ofType Γ l A let B ← ofType (Γ.snoc llen A) j B let p ← ofTerm Γ (max l j) p - Part.assert (p ≫ s[max l j].tp = s.mkSig llen jlen A B) fun p_tp => - return s.mkFst llen jlen A B p p_tp + Part.assert (p ≫ s[max l j].tp = (s.polymorphicSigma llen jlen).mkSig A B) fun p_tp => + return (s.polymorphicSigma llen jlen).mkFst A B p p_tp | .snd i _ A B p, llen => do Part.assert (i < s.length + 1) fun ilen => do let A ← ofType Γ i A let B ← ofType (Γ.snoc ilen A) l B let p ← ofTerm Γ (max i l) p - Part.assert (p ≫ s[max i l].tp = s.mkSig ilen llen A B) fun p_tp => - return s.mkSnd ilen llen A B p p_tp + Part.assert (p ≫ s[max i l].tp = (s.polymorphicSigma ilen llen).mkSig A B) fun p_tp => + return (s.polymorphicSigma ilen llen).mkSnd A B p p_tp | .refl _ t, llen => do let t ← ofTerm Γ l t return s.mkRefl llen t @@ -406,8 +411,8 @@ theorem mem_ofType_pi {Γ l i j A B} {llen : l < s.length + 1} {x} : ∃ lij : l = max i j, have ilen : i < s.length + 1 := by> omega have jlen : j < s.length + 1 := by> omega - ∃ (A' : y(Γ.fst) ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ - ∃ (B' : y((Γ.snoc ilen A').fst) ⟶ s[j].Ty), B' ∈ I.ofType (Γ.snoc ilen A') j B ∧ + ∃ (A' : Γ.fst ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ + ∃ (B' : ((Γ.snoc ilen A').fst) ⟶ s[j].Ty), B' ∈ I.ofType (Γ.snoc ilen A') j B ∧ x = lij ▸ s.mkPi ilen jlen A' B' := by dsimp only [ofType]; simp_part; exact exists_congr fun _ => by subst l; simp_part @@ -417,17 +422,17 @@ theorem mem_ofType_sigma {Γ l i j A B} {llen : l < s.length + 1} {x} : ∃ lij : l = max i j, have ilen : i < s.length + 1 := by> omega have jlen : j < s.length + 1 := by> omega - ∃ (A' : y(Γ.fst) ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ - ∃ (B' : y((Γ.snoc ilen A').fst) ⟶ s[j].Ty), B' ∈ I.ofType (Γ.snoc ilen A') j B ∧ - x = lij ▸ s.mkSig ilen jlen A' B' := by + ∃ (A' : Γ.fst ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ + ∃ (B' : ((Γ.snoc ilen A').fst) ⟶ s[j].Ty), B' ∈ I.ofType (Γ.snoc ilen A') j B ∧ + x = lij ▸ (s.polymorphicSigma ilen jlen).mkSig A' B' := by dsimp only [ofType]; simp_part; exact exists_congr fun _ => by subst l; simp_part @[simp] theorem mem_ofType_Id {Γ l i A a b} {llen : l < s.length + 1} {x} : x ∈ I.ofType Γ l (.Id i A a b) llen ↔ - ∃ (A' : y(Γ.fst) ⟶ s[l].Ty), A' ∈ I.ofType Γ l A ∧ - ∃ (a' : y(Γ.fst) ⟶ s[l].Tm), a' ∈ I.ofTerm Γ l a ∧ - ∃ (b' : y(Γ.fst) ⟶ s[l].Tm), b' ∈ I.ofTerm Γ l b ∧ + ∃ (A' : (Γ.fst) ⟶ s[l].Ty), A' ∈ I.ofType Γ l A ∧ + ∃ (a' : (Γ.fst) ⟶ s[l].Tm), a' ∈ I.ofTerm Γ l a ∧ + ∃ (b' : (Γ.fst) ⟶ s[l].Tm), b' ∈ I.ofTerm Γ l b ∧ ∃ eq : a' ≫ s[l].tp = A', ∃ eq' : b' ≫ s[l].tp = A', x = s.mkId llen A' a' b' eq eq' := by @@ -437,7 +442,7 @@ theorem mem_ofType_Id {Γ l i A a b} {llen : l < s.length + 1} {x} : theorem mem_ofType_el {Γ l t} {llen : l < s.length + 1} {x} : x ∈ I.ofType Γ l (.el t) llen ↔ ∃ llen : l < s.length, - ∃ A : y(Γ.1) ⟶ s[l+1].Tm, A ∈ I.ofTerm Γ (l+1) t ∧ + ∃ A : (Γ.1) ⟶ s[l+1].Tm, A ∈ I.ofTerm Γ (l+1) t ∧ ∃ A_tp : A ≫ s[l+1].tp = (s.homSucc l).wkU Γ.1, x = s.el llen A A_tp := by dsimp only [ofType]; simp_part @@ -450,7 +455,7 @@ theorem ofTerm_bvar {Γ l i} {llen : l < s.length + 1} : theorem mem_ofTerm_ax {Γ c A l} {llen : l < s.length + 1} {x} : x ∈ I.ofTerm Γ l (.ax c A) llen ↔ ∃ sc, I.ax c l = some sc ∧ - x = isTerminal_yUnit.from y(Γ.1) ≫ sc := by + x = isTerminal.from (Γ.1) ≫ sc := by dsimp only [ofTerm] cases I.ax c l <;> simp @@ -460,8 +465,8 @@ theorem mem_ofTerm_lam {Γ l i j A e} {llen : l < s.length + 1} {x} : ∃ lij : l = max i j, have ilen : i < s.length + 1 := by> omega have jlen : j < s.length + 1 := by> omega - ∃ (A' : y(Γ.1) ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ - ∃ (e' : y((Γ.snoc ilen A').1) ⟶ s[j].Tm), e' ∈ I.ofTerm (Γ.snoc ilen A') j e ∧ + ∃ (A' : (Γ.1) ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ + ∃ (e' : ((Γ.snoc ilen A').1) ⟶ s[j].Tm), e' ∈ I.ofTerm (Γ.snoc ilen A') j e ∧ x = lij ▸ s.mkLam ilen jlen A' e' := by dsimp only [ofTerm]; simp_part; exact exists_congr fun _ => by subst l; simp_part @@ -469,10 +474,10 @@ theorem mem_ofTerm_lam {Γ l i j A e} {llen : l < s.length + 1} {x} : theorem mem_ofTerm_app {Γ l i j B f a} {llen : l < s.length + 1} {x} : x ∈ I.ofTerm Γ l (.app i j B f a) llen ↔ ∃ ilen : i < s.length + 1, - ∃ f' : y(Γ.1) ⟶ s[max i l].Tm, f' ∈ I.ofTerm Γ (max i l) f ∧ - ∃ a' : y(Γ.1) ⟶ s[i].Tm, a' ∈ I.ofTerm Γ i a ∧ + ∃ f' : (Γ.1) ⟶ s[max i l].Tm, f' ∈ I.ofTerm Γ (max i l) f ∧ + ∃ a' : (Γ.1) ⟶ s[i].Tm, a' ∈ I.ofTerm Γ i a ∧ ∃ A', ∃ eq : a' ≫ s[i].tp = A', - ∃ B' : y((Γ.snoc ilen A').1) ⟶ s[l].Ty, + ∃ B' : ((Γ.snoc ilen A').1) ⟶ s[l].Ty, B' ∈ I.ofType (Γ.snoc ilen A') l B ∧ ∃ h, x = s.mkApp ilen llen _ B' f' h a' eq := by dsimp only [ofTerm]; simp_part; simp only [exists_prop_eq'] @@ -483,13 +488,13 @@ theorem mem_ofTerm_pair {Γ l i j B t u} {llen : l < s.length + 1} {x} : ∃ lij : l = max i j, have ilen : i < s.length + 1 := by> omega have jlen : j < s.length + 1 := by> omega - ∃ t' : y(Γ.1) ⟶ s[i].Tm, t' ∈ I.ofTerm Γ i t ∧ + ∃ t' : (Γ.1) ⟶ s[i].Tm, t' ∈ I.ofTerm Γ i t ∧ ∃ A', ∃ eq : t' ≫ s[i].tp = A', - ∃ B' : y((Γ.snoc ilen A').1) ⟶ s[j].Ty, + ∃ B' : ((Γ.snoc ilen A').1) ⟶ s[j].Ty, B' ∈ I.ofType (Γ.snoc ilen A') j B ∧ - ∃ u' : y(Γ.1) ⟶ s[j].Tm, u' ∈ I.ofTerm Γ j u ∧ - ∃ u_tp : u' ≫ s[j].tp = ym(s[i].sec _ t' eq) ≫ B', - x = lij ▸ s.mkPair ilen jlen A' B' t' eq u' u_tp := by + ∃ u' : (Γ.1) ⟶ s[j].Tm, u' ∈ I.ofTerm Γ j u ∧ + ∃ u_tp : u' ≫ s[j].tp = (s[i].sec _ t' eq) ≫ B', + x = lij ▸ (s.polymorphicSigma ilen jlen).mkPair A' B' t' eq u' u_tp := by dsimp only [ofTerm]; simp only [exists_prop_eq']; simp_part exact exists_congr fun _ => by subst l; simp_part @@ -498,12 +503,12 @@ theorem mem_ofTerm_fst {Γ l i j A B p} {llen : l < s.length + 1} {x} : x ∈ I.ofTerm Γ l (.fst i j A B p) llen ↔ have ilen : l < s.length + 1 := by> omega ∃ jlen : j < s.length + 1, - ∃ (A' : y(Γ.fst) ⟶ s[l].Ty), A' ∈ I.ofType Γ l A ∧ - ∃ B' : y((Γ.snoc llen A').1) ⟶ s[j].Ty, + ∃ (A' : (Γ.fst) ⟶ s[l].Ty), A' ∈ I.ofType Γ l A ∧ + ∃ B' : ((Γ.snoc llen A').1) ⟶ s[j].Ty, B' ∈ I.ofType (Γ.snoc llen A') j B ∧ - ∃ p' : y(Γ.1) ⟶ s[max l j].Tm, p' ∈ I.ofTerm Γ (max l j) p ∧ - ∃ p_tp : p' ≫ s[max l j].tp = s.mkSig llen jlen A' B', - x = s.mkFst llen jlen A' B' p' p_tp := by + ∃ p' : (Γ.1) ⟶ s[max l j].Tm, p' ∈ I.ofTerm Γ (max l j) p ∧ + ∃ p_tp : p' ≫ s[max l j].tp = (s.polymorphicSigma llen jlen).mkSig A' B', + x = (s.polymorphicSigma llen jlen).mkFst A' B' p' p_tp := by dsimp only [ofTerm]; simp_part @[simp] @@ -511,12 +516,12 @@ theorem mem_ofTerm_snd {Γ l i j A B p} {llen : l < s.length + 1} {x} : x ∈ I.ofTerm Γ l (.snd i j A B p) llen ↔ have llen : l < s.length + 1 := by> omega ∃ ilen : i < s.length + 1, - ∃ (A' : y(Γ.fst) ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ - ∃ B' : y((Γ.snoc ilen A').1) ⟶ s[l].Ty, + ∃ (A' : (Γ.fst) ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ + ∃ B' : ((Γ.snoc ilen A').1) ⟶ s[l].Ty, B' ∈ I.ofType (Γ.snoc ilen A') l B ∧ - ∃ p' : y(Γ.1) ⟶ s[max i l].Tm, p' ∈ I.ofTerm Γ (max i l) p ∧ - ∃ p_tp : p' ≫ s[max i l].tp = s.mkSig ilen llen A' B', - x = s.mkSnd ilen llen A' B' p' p_tp := by + ∃ p' : (Γ.1) ⟶ s[max i l].Tm, p' ∈ I.ofTerm Γ (max i l) p ∧ + ∃ p_tp : p' ≫ s[max i l].tp = (s.polymorphicSigma ilen llen).mkSig A' B', + x = (s.polymorphicSigma ilen llen).mkSnd A' B' p' p_tp := by dsimp only [ofTerm]; simp_part @[simp] @@ -529,16 +534,16 @@ theorem mem_ofTerm_refl {Γ l i t} {llen : l < s.length + 1} {x} : theorem mem_ofTerm_idRec {Γ l i j t M r u h} {llen : l < s.length + 1} {x} : x ∈ I.ofTerm Γ l (.idRec i j t M r u h) llen ↔ ∃ ilen : i < s.length + 1, - ∃ t' : y(Γ.1) ⟶ s[i].Tm, t' ∈ I.ofTerm Γ i t ∧ + ∃ t' : (Γ.1) ⟶ s[i].Tm, t' ∈ I.ofTerm Γ i t ∧ ∃ A', ∃ t_tp : t' ≫ s[i].tp = A', ∃ B' B_eq, - ∃ M' : y(((Γ.snoc ilen A').snoc ilen B').1) ⟶ s[l].Ty, + ∃ M' : (((Γ.snoc ilen A').snoc ilen B').1) ⟶ s[l].Ty, M' ∈ I.ofType ((Γ.snoc ilen A').snoc ilen B') l M ∧ - ∃ r' : y(Γ.1) ⟶ s[l].Tm, r' ∈ I.ofTerm Γ l r ∧ + ∃ r' : (Γ.1) ⟶ s[l].Tm, r' ∈ I.ofTerm Γ l r ∧ ∃ r_tp, - ∃ u' : y(Γ.1) ⟶ s[i].Tm, u' ∈ I.ofTerm Γ i u ∧ + ∃ u' : (Γ.1) ⟶ s[i].Tm, u' ∈ I.ofTerm Γ i u ∧ ∃ u_tp : u' ≫ s[i].tp = A', - ∃ h' : y(Γ.1) ⟶ s[i].Tm, h' ∈ I.ofTerm Γ i h ∧ + ∃ h' : (Γ.1) ⟶ s[i].Tm, h' ∈ I.ofTerm Γ i h ∧ ∃ h_tp : h' ≫ s[i].tp = s.mkId ilen A' t' u' t_tp u_tp, x = s.mkIdRec ilen llen A' t' t_tp B' B_eq M' r' r_tp u' u_tp h' h_tp := by dsimp only [ofTerm]; simp_part; simp only [exists_prop_eq'] @@ -547,7 +552,7 @@ theorem mem_ofTerm_idRec {Γ l i j t M r u h} {llen : l < s.length + 1} {x} : theorem mem_ofTerm_code {Γ l t} {llen : l < s.length + 1} {x} : x ∈ I.ofTerm Γ l (.code t) llen ↔ ∃ i, ∃ li : l = i + 1, - ∃ (t' : y(Γ.fst) ⟶ s[i].Ty), t' ∈ I.ofType Γ i t ∧ + ∃ (t' : (Γ.fst) ⟶ s[i].Ty), t' ∈ I.ofType Γ i t ∧ x = li ▸ s.code (by> omega) t' := by dsimp only [ofTerm]; cases l <;> simp @@ -579,12 +584,12 @@ whereas `full = true` contains general substitutions but where composition is limited to renamings on the left. -/ inductive CSb : (Δ Γ : s.CObj) → (Δ.1 ⟶ Γ.1) → (full : Bool := true) → Type _ where | id Γ (full : Bool := true) : CSb Γ Γ (𝟙 _) full - | wk {Γ : s.CObj} {l} (llen : l < s.length + 1) (A : y(Γ.1) ⟶ s[l].Ty) + | wk {Γ : s.CObj} {l} (llen : l < s.length + 1) (A : (Γ.1) ⟶ s[l].Ty) (full : Bool := true) : CSb (Γ.snoc llen A) Γ (s[l].disp A) full | comp {Θ Δ Γ : s.CObj} {σ τ full} : CSb Θ Δ σ false → CSb Δ Γ τ full → CSb Θ Γ (σ ≫ τ) full | snoc' {Δ Γ : s.CObj} {σ full} (_ : CSb Δ Γ σ full) {l} (llen : l < s.length + 1) - (A : y(Γ.1) ⟶ s[l].Ty) (e) (hf : ¬full → ∃ i, e = .bvar i) - {se : y(Δ.1) ⟶ s[l].Tm} (eq : se ≫ s[l].tp = ym(σ) ≫ A) + (A : (Γ.1) ⟶ s[l].Ty) (e) (hf : ¬full → ∃ i, e = .bvar i) + {se : (Δ.1) ⟶ s[l].Tm} (eq : se ≫ s[l].tp = (σ) ≫ A) (H : se ∈ I.ofTerm Δ l e) : CSb Δ (Γ.snoc llen A) (s[l].substCons σ A se eq) full @@ -613,37 +618,37 @@ variable {Δ Γ : s.CObj} {σ : Δ.1 ⟶ Γ.1} {full : Bool} {l : Nat} (llen : l < s.length + 1) def snoc (sσ : I.CSb Δ Γ σ) {l} (llen : l < s.length + 1) - (A : y(Γ.1) ⟶ s[l].Ty) (e) - {se : y(Δ.1) ⟶ s[l].Tm} (eq : se ≫ s[l].tp = ym(σ) ≫ A) + (A : (Γ.1) ⟶ s[l].Ty) (e) + {se : (Δ.1) ⟶ s[l].Tm} (eq : se ≫ s[l].tp = (σ) ≫ A) (H : se ∈ I.ofTerm Δ l e) : I.CSb Δ (Γ.snoc llen A) (s[l].substCons σ A se eq) := snoc' sσ llen A e (by simp) eq H @[simp] theorem snoc_toSb (sσ : I.CSb Δ Γ σ) {l} (llen : l < s.length + 1) - (A : y(Γ.1) ⟶ s[l].Ty) (e) - {se : y(Δ.1) ⟶ s[l].Tm} (eq : se ≫ s[l].tp = ym(σ) ≫ A) + (A : (Γ.1) ⟶ s[l].Ty) (e) + {se : (Δ.1) ⟶ s[l].Tm} (eq : se ≫ s[l].tp = (σ) ≫ A) (H : se ∈ I.ofTerm Δ l e) : (snoc sσ llen A e eq H).toSb = Expr.snoc sσ.toSb e := rfl -def sub1 {se : y(Γ.1) ⟶ s[l].Tm} - (A : y(Γ.1) ⟶ s[l].Ty) (e) (eq : se ≫ s[l].tp = A) (H : se ∈ I.ofTerm Γ l e) : +def sub1 {se : (Γ.1) ⟶ s[l].Tm} + (A : (Γ.1) ⟶ s[l].Ty) (e) (eq : se ≫ s[l].tp = A) (H : se ∈ I.ofTerm Γ l e) : I.CSb Γ (Γ.snoc llen A) (s[l].sec A se eq) := (CSb.id Γ).snoc llen A e (by simp [eq]) H -@[simp] theorem sub1_toSb {se : y(Γ.1) ⟶ s[l].Tm} - (A : y(Γ.1) ⟶ s[l].Ty) (e) (eq : se ≫ s[l].tp = A) (H : se ∈ I.ofTerm Γ l e) : +@[simp] theorem sub1_toSb {se : (Γ.1) ⟶ s[l].Tm} + (A : (Γ.1) ⟶ s[l].Ty) (e) (eq : se ≫ s[l].tp = A) (H : se ∈ I.ofTerm Γ l e) : (sub1 llen A e eq H).toSb = Expr.toSb e := by simp [sub1, toSb, Expr.toSb] def up {Δ Γ σ full} (sσ : I.CSb Δ Γ σ full) - {l} (llen : l < s.length + 1) (A : y(Γ.1) ⟶ s[l].Ty) - (A' := ym(σ) ≫ A) (eq : ym(σ) ≫ A = A' := by rfl) : + {l} (llen : l < s.length + 1) (A : (Γ.1) ⟶ s[l].Ty) + (A' := (σ) ≫ A) (eq : (σ) ≫ A = A' := by rfl) : I.CSb (Δ.snoc llen A') (Γ.snoc llen A) (s[l].substWk σ A _ eq) full := by refine ((CSb.wk _ _ false).comp sσ).snoc' _ _ (.bvar 0) (by simp) _ ?_ simp [UHomSeq.CObj.var, UHomSeq.ExtSeq.var] @[simp] theorem up_toSb {Δ Γ σ full} (sσ : I.CSb Δ Γ σ full) - {l} {llen : l < s.length + 1} {A A'} {eq : ym(σ) ≫ A = A'} : + {l} {llen : l < s.length + 1} {A A'} {eq : (σ) ≫ A = A'} : (up sσ llen A _ eq).toSb = Expr.up sσ.toSb := by simp [up, toSb, Expr.up_eq_snoc] @@ -651,18 +656,18 @@ end CSb /-! ## Admissibility of substitution -/ -open UHomSeq +open UHomSeq PolymorphicSigma variable (slen : univMax ≤ s.length) theorem mem_ofType_ofTerm_subst' {full} (IH : full = true → ∀ {Δ Γ l} (llen : l < s.length + 1) {sσ} (σ : I.CSb Δ Γ sσ false) {se e}, - se ∈ I.ofTerm Γ l e llen → ym(sσ) ≫ se ∈ I.ofTerm Δ l (Expr.subst σ.toSb e) llen) + se ∈ I.ofTerm Γ l e llen → (sσ) ≫ se ∈ I.ofTerm Δ l (Expr.subst σ.toSb e) llen) {e l} (llen : l < s.length + 1) {Δ Γ : s.CObj} {sσ} (σ : I.CSb Δ Γ sσ full) {σ'} (eq : σ.toSb = σ') : (∀ {sA}, sA ∈ I.ofType Γ l e llen → - ym(sσ) ≫ sA ∈ I.ofType Δ l (Expr.subst σ' e) llen) ∧ + (sσ) ≫ sA ∈ I.ofType Δ l (Expr.subst σ' e) llen) ∧ (∀ {se}, se ∈ I.ofTerm Γ l e llen → - ym(sσ) ≫ se ∈ I.ofTerm Δ l (Expr.subst σ' e) llen) := by + (sσ) ≫ se ∈ I.ofTerm Δ l (Expr.subst σ' e) llen) := by subst σ' induction e generalizing Δ Γ l <;> (constructor <;> [intro sA H; intro se H] <;> try cases Part.notMem_none _ H) @@ -729,17 +734,19 @@ theorem mem_ofType_ofTerm_subst' {full} case app ihB ihf iha => obtain ⟨llen', f, hf, a, ha, _, rfl, B, hB, eq, rfl⟩ := I.mem_ofTerm_app.1 H simp only [Expr.subst, comp_mkApp, mem_ofTerm_app] - refine ⟨‹_›, _, (ihf (by simp [*]) σ).2 hf, _, (iha llen' σ).2 ha, _, rfl, _, ?_, ?_, rfl⟩ - · rw [← CSb.up_toSb]; exact (ihB llen (σ.up llen' _ _ (Category.assoc ..).symm)).1 hB - · simp [*, comp_mkPi] - congr! 1 + -- refine ⟨‹_›, _, (ihf (by simp [*]) σ).2 hf, _, (iha llen' σ).2 ha, _, rfl, _, ?_, ?_, rfl⟩ + -- · rw [← CSb.up_toSb]; exact (ihB llen (σ.up llen' _ _ (Category.assoc ..).symm)).1 hB + -- · simp [*, comp_mkPi] + -- congr! 1 + sorry case pair ihB iht ihu => obtain ⟨rfl, H⟩ := I.mem_ofTerm_pair.1 H; simp at H llen obtain ⟨t, ht, B, hB, u, hu, eq, rfl⟩ := H; clear H simp only [Expr.subst, comp_mkPair, mem_ofTerm_pair, exists_true_left] - refine ⟨_, (iht llen.1 σ).2 ht, _, rfl, _, ?_, _, (ihu llen.2 σ).2 hu, ?_, rfl⟩ - · rw [← CSb.up_toSb]; exact (ihB llen.2 (σ.up llen.1 _ _ (Category.assoc ..).symm)).1 hB - · simp [*]; rw [← Functor.map_comp_assoc, comp_sec, ← Functor.map_comp_assoc]; congr! 0 + -- refine ⟨_, (iht llen.1 σ).2 ht, _, rfl, _, ?_, _, (ihu llen.2 σ).2 hu, ?_, rfl⟩ + -- · rw [← CSb.up_toSb]; exact (ihB llen.2 (σ.up llen.1 _ _ (Category.assoc ..).symm)).1 hB + -- · simp [*]; rw [← Functor.map_comp_assoc, comp_sec, ← Functor.map_comp_assoc]; congr! 0 + sorry case fst ihA ihB ihp => obtain ⟨jlen, A, hA, B, hB, p, hp, eq, rfl⟩ := I.mem_ofTerm_fst.1 H simp only [Expr.subst, comp_mkFst, mem_ofTerm_fst] @@ -764,7 +771,7 @@ theorem mem_ofType_ofTerm_subst' {full} _, (ihr llen σ).2 hr, _, _, (ihu ilen σ).2 hu, _, _, (ihh ilen σ).2 hh, _, comp_mkIdRec (σA_eq := rfl) (σB_eq := rfl) ..⟩ · simp [← Beq, comp_mkId (eq := rfl)] - congr 1 <;> simp only [← Functor.map_comp_assoc, substWk_disp] + congr 1 <;> simp only [← Category.assoc, substWk_disp] · rw [← CSb.up_toSb, ← CSb.up_toSb]; exact (ihM llen ((σ.up ilen _).up ilen _ _ _)).1 hM case code ihA => obtain ⟨l, rfl, H⟩ := I.mem_ofTerm_code.1 H; simp at H llen @@ -779,21 +786,21 @@ theorem mem_ofType_ofTerm_subst' {full} theorem mem_ofType_ofTerm_subst {e l} (llen : l < s.length + 1) {Δ Γ : s.CObj} {sσ full} (σ : I.CSb Δ Γ sσ full) {σ'} (eq : σ.toSb = σ') : (∀ {sA}, sA ∈ I.ofType Γ l e llen → - ym(sσ) ≫ sA ∈ I.ofType Δ l (Expr.subst σ' e) llen) ∧ + (sσ) ≫ sA ∈ I.ofType Δ l (Expr.subst σ' e) llen) ∧ (∀ {se}, se ∈ I.ofTerm Γ l e llen → - ym(sσ) ≫ se ∈ I.ofTerm Δ l (Expr.subst σ' e) llen) := by + (sσ) ≫ se ∈ I.ofTerm Δ l (Expr.subst σ' e) llen) := by refine I.mem_ofType_ofTerm_subst' (fun _ _ _ _ llen sσ σ se i => ?_) llen σ eq exact (I.mem_ofType_ofTerm_subst' (by simp) llen σ rfl).2 theorem mem_ofType_wk {e l l' hl} (hl' : l' < s.length + 1) - {Γ : s.CObj} {X : y(Γ.1) ⟶ s[l'].Ty} + {Γ : s.CObj} {X : (Γ.1) ⟶ s[l'].Ty} {se} (H : se ∈ I.ofType Γ l e hl) : - ym(s[l'].disp X) ≫ se ∈ I.ofType (Γ.snoc hl' X) l (Expr.subst Expr.wk e) hl := + (s[l'].disp X) ≫ se ∈ I.ofType (Γ.snoc hl' X) l (Expr.subst Expr.wk e) hl := (I.mem_ofType_ofTerm_subst hl (.wk hl' X) rfl).1 H theorem mem_ofType_of_isClosed {e l} (e_cl : e.isClosed) (Γ : s.CObj) (hl : l < s.length + 1) {se} (se_mem : se ∈ I.ofType s.nilCObj l e hl) : - isTerminal_yUnit.from y(Γ.1) ≫ se ∈ I.ofType Γ l e hl := by + isTerminal.from Γ.1 ≫ se ∈ I.ofType Γ l e hl := by rcases Γ with ⟨_, ext⟩ induction ext · convert se_mem; simp @@ -803,23 +810,23 @@ theorem mem_ofType_of_isClosed {e l} (e_cl : e.isClosed) simp [e.subst_of_isClosed _ e_cl, UHomSeq.CObj.snoc] theorem mem_ofTerm_wk {e l l' hl} (hl' : l' < s.length + 1) - {Γ : s.CObj} {X : y(Γ.1) ⟶ s[l'].Ty} + {Γ : s.CObj} {X : Γ.1 ⟶ s[l'].Ty} {se} (H : se ∈ I.ofTerm Γ l e hl) : - ym(s[l'].disp X) ≫ se ∈ I.ofTerm (Γ.snoc hl' X) l (Expr.subst Expr.wk e) hl := + (s[l'].disp X) ≫ se ∈ I.ofTerm (Γ.snoc hl' X) l (Expr.subst Expr.wk e) hl := (I.mem_ofType_ofTerm_subst hl (.wk hl' X) rfl).2 H theorem mem_ofType_toSb {e l l' hl} (hl' : l' < s.length + 1) - {Γ : s.CObj} {A : y(Γ.1) ⟶ s[l'].Ty} + {Γ : s.CObj} {A : Γ.1 ⟶ s[l'].Ty} {a sa} (ha : sa ∈ I.ofTerm Γ l' a hl') (eq : sa ≫ s[l'].tp = A) {se} (H : se ∈ I.ofType (Γ.snoc hl' A) l e hl) : - ym(s[l'].sec A sa eq) ≫ se ∈ I.ofType Γ l (Expr.subst a.toSb e) hl := + (s[l'].sec A sa eq) ≫ se ∈ I.ofType Γ l (Expr.subst a.toSb e) hl := (I.mem_ofType_ofTerm_subst hl (.sub1 _ _ _ eq ha) (by simp)).1 H theorem mem_ofTerm_toSb {e l l' hl} (hl' : l' < s.length + 1) - {Γ : s.CObj} {A : y(Γ.1) ⟶ s[l'].Ty} + {Γ : s.CObj} {A : Γ.1 ⟶ s[l'].Ty} {a sa} (ha : sa ∈ I.ofTerm Γ l' a hl') (eq : sa ≫ s[l'].tp = A) {se} (H : se ∈ I.ofTerm (Γ.snoc hl' A) l e hl) : - ym(s[l'].sec A sa eq) ≫ se ∈ I.ofTerm Γ l (Expr.subst a.toSb e) hl := + (s[l'].sec A sa eq) ≫ se ∈ I.ofTerm Γ l (Expr.subst a.toSb e) hl := (I.mem_ofType_ofTerm_subst hl (.sub1 _ _ _ eq ha) (by simp)).2 H /-! ## Soundness of interpretation -/ @@ -1195,7 +1202,7 @@ theorem EqTmIH.trans {Γ A t t' t'' l} : structure Wf (I : Interpretation χ s) (E : Axioms χ) : Prop where ax {c Al} (Ec : E c = some Al) : ∃ sc, I.ax c Al.1.2 = some sc ∧ - ∃ sA : y(𝟭_ 𝒞) ⟶ s[Al.1.2].Ty, + ∃ sA : (𝟭_ 𝒞) ⟶ s[Al.1.2].Ty, sA ∈ I.ofType s.nilCObj Al.1.2 Al.1.1 ∧ sc ≫ s[Al.1.2].tp = sA @@ -1281,7 +1288,7 @@ def interpCtx (H : WfCtx E Γ) : s.CObj := Part.get_mem .. /-- Given `Γ, l, A` s.t. `Γ ⊢[l] A`, return `⟦A⟧_⟦Γ⟧`. -/ -def interpTy (H : E ∣ Γ ⊢[l] A) : y(I.interpCtx H.wf_ctx |>.1) ⟶ (s[l]'(H.lt_slen slen)).Ty := +def interpTy (H : E ∣ Γ ⊢[l] A) : (I.interpCtx H.wf_ctx |>.1) ⟶ (s[l]'(H.lt_slen slen)).Ty := (I.ofType _ l A (H.lt_slen slen)).get <| by have ⟨_, h1, _, h2⟩ := I.ofType_ofTerm_sound.2.1 H cases Part.mem_unique (I.interpCtx_mem H.wf_ctx) h1 @@ -1299,7 +1306,7 @@ theorem interpTy_eq (H : E ∣ Γ ⊢[l] A ≡ B) : /-- Given `Γ, l, t, A` s.t. `Γ ⊢[l] t : A`, return `⟦t⟧_⟦Γ⟧`. -/ def interpTm (H : E ∣ Γ ⊢[l] t : A) : - y(I.interpCtx H.wf_ctx |>.1) ⟶ (s[l]'(H.lt_slen slen)).Tm := + (I.interpCtx H.wf_ctx |>.1) ⟶ (s[l]'(H.lt_slen slen)).Tm := (I.ofTerm _ l t (H.lt_slen slen)).get <| by have ⟨_, h1, _, _, _, _, ⟨h2, rfl⟩, _⟩ := I.ofType_ofTerm_sound.2.2.2.1 H cases Part.mem_unique (I.interpCtx_mem H.wf_ctx) h1 @@ -1320,11 +1327,11 @@ theorem interpTm_eq (H : E ∣ Γ ⊢[l] t ≡ u : A) : cases Part.mem_unique (I.interpCtx_mem H.wf_ctx) h1 exact h2 -def empty (χ : Type*) (s : UHomSeq 𝒞) : Interpretation χ s where +def empty (χ : Type*) (s : UHomSeq R) : Interpretation χ s where ax _ _ _ := none def snoc [DecidableEq χ] (I : Interpretation χ s) (c : χ) (l : Nat) (l_lt : l < s.length) - (sc : y(𝟭_ 𝒞) ⟶ s[l].Tm) : + (sc : (𝟭_ 𝒞) ⟶ s[l].Tm) : Interpretation χ s where ax d k _ := if h : c = d ∧ k = l then some (h.2 ▸ sc) else I.ax d k diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index 43381a7d..a4ab44c5 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -227,8 +227,6 @@ 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] -instance : HasTerminal Ctx := IsTerminal.hasTerminal (ChosenTerminal.isTerminal) - def Ptp : Ctx ⥤ Ctx := M.uvPolyTp.functor namespace PtpEquiv diff --git a/HoTTLean/Model/UHom.lean b/HoTTLean/Model/UHom.lean index 0281611c..ad5f02e8 100644 --- a/HoTTLean/Model/UHom.lean +++ b/HoTTLean/Model/UHom.lean @@ -66,7 +66,7 @@ variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] def Hom.cartesianNatTrans {M N : Universe R} (h : Hom M N) : M.Ptp ⟶ N.Ptp := - M.uvPolyTp.cartesianNatTrans N.uvPolyTp h.mapTy h.mapTm h.pb.flip + M.uvPolyTp.cartesianNatTrans N.uvPolyTp h.mapTy h.mapTm h.pb @[simp] def Hom.extIsoExt {M N : Universe R} (h : Hom M N) {Γ} (A : (Γ) ⟶ M.Ty) : (N.ext (A ≫ h.mapTy)) ≅ (M.ext A) := From 2ffef86fca6999c7b33ea7522b0289ac7f5ab321 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 30 Sep 2025 00:50:39 -0400 Subject: [PATCH 15/59] some more id refactoring --- HoTTLean/Model/NaturalModel.lean | 64 ++++++++++++++------------------ HoTTLean/Model/UHom.lean | 28 +++++++------- 2 files changed, 42 insertions(+), 50 deletions(-) diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index a4ab44c5..133f9995 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -4,7 +4,6 @@ import Mathlib.CategoryTheory.Limits.Shapes.KernelPair import HoTTLean.ForMathlib import HoTTLean.ForMathlib.Tactic.CategoryTheory.FunctorMap -import HoTTLean.ForMathlib.CategoryTheory.Yoneda import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone import HoTTLean.ForMathlib.CategoryTheory.WeakPullback import HoTTLean.ForMathlib.CategoryTheory.Polynomial @@ -118,13 +117,12 @@ def substCons {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) theorem substCons_disp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (t : Δ ⟶ M.Tm) (tTp : t ≫ M.tp = σ ≫ A) : M.substCons σ A t tTp ≫ M.disp A = σ := by - apply Yoneda.fullyFaithful.map_injective 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 + M.substCons σ A t aTp ≫ M.var A = t := by simp [substCons] @[simp] @@ -184,7 +182,7 @@ theorem substWk_disp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (A' eq) : @[reassoc (attr := simp)] theorem substWk_var {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (A' eq) : - (M.substWk σ A A' eq) ≫ M.var A = M.var A' := by + M.substWk σ A A' eq ≫ M.var A = M.var A' := by simp [substWk] /-- `sec` is the section of `disp A` corresponding to `a`. @@ -208,7 +206,7 @@ theorem sec_disp {Γ : Ctx} (A : Γ ⟶ M.Ty) (a : Γ ⟶ M.Tm) (a_tp : a ≫ M. @[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 + M.sec A a a_tp ≫ M.var A = a := by simp [sec] @[reassoc] @@ -777,7 +775,7 @@ theorem mkRefl_tp (a : Γ ⟶ M.Tm) : ... -/ def motiveCtx (a : Γ ⟶ M.Tm) : Ctx := - M.ext (idIntro.mkId ((M.disp (a ≫ M.tp)) ≫ a) (M.var _) (by simp)) + 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 @@ -805,8 +803,7 @@ theorem comp_reflSubst' {Γ Δ} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) : @[simp, reassoc] lemma comp_reflSubst (a : Γ ⟶ M.Tm) {Δ} (σ : Δ ⟶ Γ) : reflSubst idIntro (σ ≫ a) ≫ idIntro.motiveSubst σ a = σ ≫ reflSubst idIntro a := by - apply Yoneda.fullyFaithful.map_injective - simp [Functor.map_comp, comp_reflSubst'] + 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) @@ -830,25 +827,25 @@ Note that the universe/model `N` for the motive `C` is different from the univer identity type lives in. -/ protected structure Id' (i : IdIntro M) (N : Universe R) where - j {Γ} (a : Γ ⟶ M.Tm) (C : (IdIntro.motiveCtx _ a) ⟶ N.Ty) (r : Γ ⟶ N.Tm) + 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) + 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) + (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 + 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) + 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 : Universe R} {ii : M.IdIntro} (i : M.Id' ii N) {Γ : Ctx} (a : Γ ⟶ M.Tm) - (C : (ii.motiveCtx a) ⟶ N.Ty) (r : Γ ⟶ N.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) @@ -1008,7 +1005,6 @@ open IdElimBase IdIntro section Equiv variable {Γ : Ctx} {X : Ctx} -/- section variable (a : Γ ⟶ M.Tm) /- @@ -1034,16 +1030,13 @@ where `pullback` is the pullback of `i₂ ≫ k₂` along `a` given by `HasPullb -/ lemma toK_comp_left {Δ} (σ : Δ ⟶ Γ) : ii.toK (σ ≫ a) = - (M.substWk σ (a ≫ M.tp)) ≫ ii.toK a := by + (M.substWk σ (a ≫ M.tp) _ (by simp)) ≫ ii.toK a := by dsimp [toK] + rw! [Category.assoc] apply ii.isKernelPair.hom_ext - -- FIXME: `transparency := .default` is like `erw` and should be avoided - · rw! (transparency := .default) [Category.assoc] - simp + · simp · simp only [IsKernelPair.lift_snd, Category.assoc] - slice_rhs 1 2 => rw [← Functor.map_comp, substWk_disp] - -- FIXME: `transparency := .default` is like `erw` and should be avoided - rw! (transparency := .default) [Category.assoc] + slice_rhs 1 2 => rw [substWk_disp] simp def toI : (ii.motiveCtx a) ⟶ ie.i := @@ -1056,12 +1049,11 @@ 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 + ii.motiveSubst σ a ≫ toI ie a := by dsimp [toI] apply ie.i_isPullback.hom_ext · simp [motiveSubst] · simp [toK_comp_left, motiveSubst, substWk, substCons] - rfl theorem motiveCtx_isPullback : IsPullback (ie.toI a) (M.disp _) ie.i2 (toK ii a) := @@ -1074,11 +1066,11 @@ theorem motiveCtx_isPullback' : (ii.ext_a_tp_isPullback a) def equivMk (x : (ii.motiveCtx a) ⟶ X) : Γ ⟶ ie.iFunctor.obj X := - UvPoly.Equiv.mk' ie.iUvPoly X a (ie.motiveCtx_isPullback' a).flip x + UvPoly.Equiv.mk' a (ie.motiveCtx_isPullback' a).flip x def equivFst (pair : Γ ⟶ ie.iFunctor.obj X) : Γ ⟶ M.Tm := - UvPoly.Equiv.fst ie.iUvPoly X pair + UvPoly.Equiv.fst pair lemma equivFst_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) {Δ} (σ : Δ ⟶ Γ) : @@ -1088,12 +1080,13 @@ lemma equivFst_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) def equivSnd (pair : Γ ⟶ ie.iFunctor.obj X) : (ii.motiveCtx (equivFst ie pair)) ⟶ X := - UvPoly.Equiv.snd' ie.iUvPoly X pair (ie.motiveCtx_isPullback' _).flip + UvPoly.Equiv.snd' pair (ie.motiveCtx_isPullback' _).flip +#exit lemma equivSnd_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) {Δ} (σ : Δ ⟶ Γ) : ie.equivSnd (σ ≫ pair) = - (ii.motiveSubst σ _) ≫ ie.equivSnd pair := by + eqToHom (by simp [equivFst_comp_left]) ≫ ii.motiveSubst σ _ ≫ ie.equivSnd pair := by dsimp only [equivSnd] let a := ie.equivFst pair have H : IsPullback (ie.toI a) @@ -1229,9 +1222,8 @@ variable {Γ Δ : Ctx} (σ : Δ ⟶ Γ) (a : Γ ⟶ M.Tm) open IdElimBase IdIntro -#exit -lemma reflCase_aux : IsPullback (𝟙 Γ) a a (UvPoly.id M.Tm).p := - have : IsIso (UvPoly.id M.Tm).p := by simp; infer_instance +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`, @@ -1247,12 +1239,12 @@ Tm <-- Γ --------> Tm a ``` -/ -def reflCase : Γ ⟶ (UvPoly.id M.Tm).functor.obj N.Tm := - UvPoly.Equiv.mk' (UvPoly.id M.Tm) N.Tm a (R := Γ) (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` +#exit variable (ie) in /-- The variable `C` is the motive for elimination, This gives a map `(a, C) : Γ ⟶ iFunctor Ty` diff --git a/HoTTLean/Model/UHom.lean b/HoTTLean/Model/UHom.lean index ad5f02e8..e86a05d4 100644 --- a/HoTTLean/Model/UHom.lean +++ b/HoTTLean/Model/UHom.lean @@ -547,21 +547,21 @@ theorem mkApp_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty simp [mkApp] theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : - (σ) ≫ s.mkApp ilen jlen A B f f_tp a a_tp = - s.mkApp ilen jlen σA ((s[i].substWk σ A _ eq) ≫ B) - ((σ) ≫ f) (by simp [f_tp, comp_mkPi (eq := eq)]) - ((σ) ≫ a) (by simp [a_tp, eq]) := by + (A : Γ ⟶ s[i].Ty) (σA) (eq : σ ≫ A = σA) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) + (a : Γ ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : + σ ≫ s.mkApp ilen jlen A B f f_tp a a_tp = + s.mkApp ilen jlen σA (s[i].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 : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +theorem mkLam_unLam {Γ : Ctx} (A : Γ ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) + (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : s.mkLam ilen jlen A (s.unLam ilen jlen A B f f_tp) = f := by - let total : (Γ) ⟶ s[i].Ptp.obj s[j].Tm := + let total : Γ ⟶ s[i].Ptp.obj s[j].Tm := (s.Pi_pb ilen jlen).lift f (PtpEquiv.mk s[i] A B) f_tp simp only [mkLam, unLam] have : PtpEquiv.fst s[i] total = A := by @@ -574,8 +574,8 @@ theorem mkLam_unLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j] apply (s.Pi_pb ilen jlen).lift_fst @[simp] -theorem unLam_mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (t : (s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) +theorem unLam_mkLam {Γ : Ctx} (A : Γ ⟶ s[i].Ty) (B : s[i].ext A ⟶ s[j].Ty) + (t : s[i].ext A ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) (lam_tp : s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B) : s.unLam ilen jlen A B (s.mkLam ilen jlen A t) lam_tp = t := by simp [mkLam, unLam] @@ -591,11 +591,11 @@ theorem unLam_mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j] ``` -/ def etaExpand {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : + (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : (Γ) ⟶ s[max i j].Tm := s.mkLam ilen jlen A <| s.mkApp ilen jlen - ((s[i].disp A) ≫ A) ((s[i].substWk ..) ≫ B) ((s[i].disp A) ≫ f) + (s[i].disp A ≫ A) (s[i].substWk .. ≫ B) (s[i].disp A ≫ f) (by simp [f_tp, comp_mkPi]) (s[i].var A) (s[i].var_tp A) From 2fc4bb3df041a9429d29f23f3d443722e83aae7e Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 30 Sep 2025 10:21:46 -0400 Subject: [PATCH 16/59] feat: ofUnstructured --- HoTTLean/Model/NaturalModel.lean | 361 ++++++++++--------------------- HoTTLean/Model/UHom.lean | 2 + HoTTLean/Model/Unstructured.lean | 277 ++++++++++++++++++++++++ 3 files changed, 392 insertions(+), 248 deletions(-) create mode 100644 HoTTLean/Model/Unstructured.lean diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean index 133f9995..813dce9f 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/NaturalModel.lean @@ -1,12 +1,10 @@ import Mathlib.CategoryTheory.Limits.Shapes.KernelPair --- import Poly.ForMathlib.CategoryTheory.LocallyCartesianClosed.Presheaf --- import Poly.UvPoly.UPFan - 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 universe v u @@ -19,19 +17,14 @@ namespace NaturalModel /-- 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 Universe {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) where - Tm : Ctx - Ty : Ctx - tp : Tm ⟶ Ty +structure Universe {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) + extends UnstructuredModel.Universe Ctx where morphismProperty : R tp - 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 Universe +open UnstructuredModel.Universe + variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} (M : Universe R) [R.HasPullbacks] [R.IsStableUnderBaseChange] @@ -49,16 +42,8 @@ def pullbackIsoExt {Γ : Ctx} (A : Γ ⟶ M.Ty) : /-- Pull a natural model back along a type. -/ protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : Universe R where - Tm := M.ext A - Ty := Γ - tp := M.disp A + __ := UnstructuredModel.Universe.pullback M.toUniverse A morphismProperty := R.of_isPullback (disp_pullback ..) M.morphismProperty - 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, @@ -80,141 +65,8 @@ def ofIsPullback {U E : Ctx} {π : E ⟶ U} {toTy : U ⟶ M.Ty} {toTm : E ⟶ M.Tm} (pb : IsPullback toTm π M.tp toTy) : Universe R where - Ty := U - Tm := E - tp := π + __ := UnstructuredModel.Universe.ofIsPullback M.toUniverse pb morphismProperty := R.of_isPullback pb M.morphismProperty - 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 - -/-- -``` -Δ ⊢ σ : Γ.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]; rw [(M.disp_pullback _).w] - -@[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] - -/-- -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] /-! ## Polynomial functor on `tp` @@ -392,7 +244,7 @@ lemma dependent_eq (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) theorem comp_dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) {A} (eq1 : fst ab ≫ M.tp = A) {σA} (eq2 : σ ≫ A = σA) : - (substWk M σ _ _ eq2) ≫ dependent ab A eq1 = + (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) @@ -677,20 +529,34 @@ theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty end -end PolymorphicSigma +def ofUnstructured (U0 U1 U2 : Universe R) + (S : UnstructuredModel.Universe.PolymorphicSigma U0.toUniverse U1.toUniverse U2.toUniverse) : + PolymorphicSigma U0 U1 U2 where + Sig := ofYoneda (fun AB => S.Sig (PtpEquiv.snd U0 AB)) (by + intro Δ Γ σ A + simp only [← S.Sig_comp, PtpEquiv.snd_comp_left, PtpEquiv.fst_comp_left] + rw! [PtpEquiv.fst_comp_left]) + pair := ofYoneda (fun ab => S.pair (compDomEquiv.dependent ab) (compDomEquiv.fst ab) + (by rw [compDomEquiv.fst_tp]) (compDomEquiv.snd ab) (by rw [compDomEquiv.snd_tp])) (by + intro Δ Γ σ A + simp only [← S.pair_comp, compDomEquiv.comp_dependent, compDomEquiv.fst_comp, + compDomEquiv.snd_comp] + rw! [compDomEquiv.fst_comp, Category.assoc]) + Sig_pullback := sorry -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 (substWk M σ A σA eq ≫ B)).hom ≫ substWk M σ _ _ (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 +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 @@ -1082,93 +948,92 @@ def equivSnd (pair : Γ ⟶ ie.iFunctor.obj X) : (ii.motiveCtx (equivFst ie pair)) ⟶ X := UvPoly.Equiv.snd' pair (ie.motiveCtx_isPullback' _).flip -#exit lemma equivSnd_comp_left (pair : Γ ⟶ ie.iFunctor.obj X) {Δ} (σ : Δ ⟶ Γ) : ie.equivSnd (σ ≫ pair) = eqToHom (by simp [equivFst_comp_left]) ≫ ii.motiveSubst σ _ ≫ ie.equivSnd pair := by - 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] + 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 diff --git a/HoTTLean/Model/UHom.lean b/HoTTLean/Model/UHom.lean index e86a05d4..276392c6 100644 --- a/HoTTLean/Model/UHom.lean +++ b/HoTTLean/Model/UHom.lean @@ -15,6 +15,8 @@ namespace NaturalModel namespace Universe +open UnstructuredModel.Universe + variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} (M : Universe R) [R.HasPullbacks] [R.IsStableUnderBaseChange] diff --git a/HoTTLean/Model/Unstructured.lean b/HoTTLean/Model/Unstructured.lean new file mode 100644 index 00000000..38068ecb --- /dev/null +++ b/HoTTLean/Model/Unstructured.lean @@ -0,0 +1,277 @@ +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 + +universe u v + +noncomputable section + +open CategoryTheory Limits Opposite + +namespace UnstructuredModel + +/-- 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 Universe (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 Universe + +variable {Ctx : Type u} [Category Ctx] (M : Universe Ctx) + +/-! ## Pullback of representable natural transformation -/ + +/-- Pull a natural model back along a type. -/ +protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : Universe 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) : + Universe 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 + +/-- +``` +Δ ⊢ σ : Γ.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]; rw [(M.disp_pullback _).w] + +@[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] + +/-- +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] + +structure PolymorphicSigma (U0 U1 U2 : Universe 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_tp : 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_tp : s ≫ U2.tp = Sig B), Γ ⟶ U0.Tm) + (fst_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} + (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = Sig B), + fst (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by cat_disch) = σ ≫ fst B s s_tp) + (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_tp : s ≫ U2.tp = Sig B), Γ ⟶ U1.Tm) + (snd_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} + (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = Sig B), + snd (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by cat_disch) = σ ≫ snd B s s_tp) + (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) + +-- def Sigma.mk'' {U0 U1 U2 : Universe R} +-- (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_tp : 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_tp : s ≫ U2.tp = Sig B), Γ ⟶ U0.Tm) +-- (fst_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} +-- (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = Sig B), +-- fst (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by cat_disch) = σ ≫ fst B s s_tp) +-- (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_tp : s ≫ U2.tp = Sig B), Γ ⟶ U1.Tm) +-- (snd_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} +-- (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = Sig B), +-- snd (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by cat_disch) = σ ≫ snd B s s_tp) +-- (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 : sorry) +-- (snd_pair : sorry) +-- (eta : sorry) +-- : PolymorphicSigma U0 U1 U2 := +-- sorry From 7f5ba2a0b9cfa94b7f1d171e56be91be503b21ea Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 1 Oct 2025 00:44:05 -0400 Subject: [PATCH 17/59] sigma full refactor through unstructured model --- HoTTLean/Grothendieck/Groupoidal/Basic.lean | 25 +- HoTTLean/Groupoids/Basic.lean | 1 - HoTTLean/Groupoids/IsPullback.lean | 1 - HoTTLean/Groupoids/NaturalModelBase.lean | 423 -------- HoTTLean/Groupoids/Sigma.lean | 391 +++---- HoTTLean/Groupoids/SigmaBackup.lean | 999 ++++++++++++++++++ HoTTLean/Groupoids/StructuredModel.lean | 358 +++++++ HoTTLean/Groupoids/UHom.lean | 33 + HoTTLean/Groupoids/UnstructuredModel.lean | 128 +++ HoTTLean/Model/Interpretation.lean | 13 +- ...NaturalModel.lean => StructuredModel.lean} | 135 ++- HoTTLean/Model/UHom.lean | 202 ++-- ...structured.lean => UnstructuredModel.lean} | 40 +- 13 files changed, 1975 insertions(+), 774 deletions(-) delete mode 100644 HoTTLean/Groupoids/NaturalModelBase.lean create mode 100644 HoTTLean/Groupoids/SigmaBackup.lean create mode 100644 HoTTLean/Groupoids/StructuredModel.lean create mode 100644 HoTTLean/Groupoids/UHom.lean create mode 100644 HoTTLean/Groupoids/UnstructuredModel.lean rename HoTTLean/Model/{NaturalModel.lean => StructuredModel.lean} (90%) rename HoTTLean/Model/{Unstructured.lean => UnstructuredModel.lean} (79%) diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index 7d02694b..11d00434 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -470,6 +470,28 @@ def asFunctorFrom_hom {c c' : C} (f: c ⟶ c') : asFunctorFrom_fib K c ⟶ F.map f ⋙ asFunctorFrom_fib K c' := Grothendieck.asFunctorFrom_hom K f +section + +variable {E : Type*} [Category E] +variable (fib : ∀ c, F.obj c ⥤ E) (hom : ∀ {c c' : C} (f : c ⟶ c'), fib c ⟶ F.map f ⋙ fib c') +variable (hom_id : ∀ c, hom (𝟙 c) = eqToHom (by simp only [Functor.map_id]; rfl)) +variable (hom_comp : ∀ c₁ c₂ c₃ (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃), hom (f ≫ g) = + hom f ≫ (F.map f).whiskerLeft (hom g) ≫ eqToHom (by simp only [Functor.map_comp]; rfl)) + +lemma asFunctorFrom_fib_functorFrom : + asFunctorFrom_fib (functorFrom fib hom hom_id hom_comp) = fib := by + unfold asFunctorFrom_fib functorFrom + simp + sorry + +-- lemma asFunctorFrom_hom_functorFrom {K} {c c' : C} (f : c ⟶ c') : + -- asFunctorFrom_hom (functorFrom fib hom hom_id hom_comp) K f ≫ eqToHom sorry = + -- eqToHom sorry ≫ hom K f := by + -- unfold asFunctorFrom_fib functorFrom + -- simp + -- sorry +end + lemma asFunctorFrom_hom' {c c' : C} (f: c ⟶ c') : asFunctorFrom_hom K f = whiskerRight (ιNatTrans f) K := rfl @@ -480,9 +502,6 @@ lemma asFunctorFrom_hom_app {c c' : C} (f: c ⟶ c') (p : F.obj c) : lemma asFunctorFrom_hom_id (c : C) : asFunctorFrom_hom K (𝟙 c) = eqToHom (by simp) := Grothendieck.asFunctorFrom_hom_id _ _ - -- by - -- ext p - -- simp [asFunctorFrom_hom_app, eqToHom_map, ιNatTrans_id_app] lemma asFunctorFrom_hom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g: c₂ ⟶ c₃) : asFunctorFrom_hom K (f ≫ g) = diff --git a/HoTTLean/Groupoids/Basic.lean b/HoTTLean/Groupoids/Basic.lean index 050c6f16..9c3ca063 100644 --- a/HoTTLean/Groupoids/Basic.lean +++ b/HoTTLean/Groupoids/Basic.lean @@ -4,7 +4,6 @@ import Mathlib.CategoryTheory.Category.Cat.Limit import Mathlib.CategoryTheory.Monoidal.Cartesian.Cat import HoTTLean.ForMathlib.CategoryTheory.Core -import HoTTLean.Model.NaturalModel import HoTTLean.Grothendieck.Groupoidal.IsPullback import HoTTLean.ForMathlib.CategoryTheory.FreeGroupoid diff --git a/HoTTLean/Groupoids/IsPullback.lean b/HoTTLean/Groupoids/IsPullback.lean index 09a44f16..be866c08 100644 --- a/HoTTLean/Groupoids/IsPullback.lean +++ b/HoTTLean/Groupoids/IsPullback.lean @@ -1,7 +1,6 @@ import Mathlib.CategoryTheory.Limits.Preserves.FunctorCategory import Mathlib.CategoryTheory.Category.Cat.Limit -import HoTTLean.Model.NaturalModel import HoTTLean.Grothendieck.Groupoidal.IsPullback import HoTTLean.Groupoids.Basic diff --git a/HoTTLean/Groupoids/NaturalModelBase.lean b/HoTTLean/Groupoids/NaturalModelBase.lean deleted file mode 100644 index 1409cb9d..00000000 --- a/HoTTLean/Groupoids/NaturalModelBase.lean +++ /dev/null @@ -1,423 +0,0 @@ -import Mathlib.CategoryTheory.Limits.Preserves.FunctorCategory -import Mathlib.CategoryTheory.Category.Cat.Limit - -import HoTTLean.Model.UHom -import HoTTLean.Grothendieck.Groupoidal.IsPullback -import HoTTLean.Groupoids.IsPullback -import HoTTLean.ForMathlib.CategoryTheory.IsIsofibration - -/-! -Here we construct universes for the groupoid natural model. --/ - -universe w v u v₁ u₁ v₂ u₂ v₃ u₃ - -noncomputable section -open CategoryTheory Limits NaturalModel Universe - Functor.Groupoidal GroupoidModel.Ctx GroupoidModel.U - -namespace GroupoidModel - -open U - -/-- The universe the classifies `v`-large terms and types. - The π-clan we use is the set of groupoid isofibrations. --/ -@[simps] -def U : Universe Grpd.IsIsofibration where - Ty := Ty.{v} - Tm := Tm.{v} - tp := tp - morphismProperty := sorry - ext A := ext A - disp A := disp A - var A := var A - disp_pullback A := GroupoidModel.IsPullback.disp_pullback A - -namespace U - -open MonoidalCategory - -def asSmallClosedType : (tensorUnit _ : Ctx) ⟶ Ty.{v+1, max u (v+2)} := - toCoreAsSmallEquiv.symm ((Functor.const _).obj - (Grpd.of (Core (AsSmall.{v+1} Grpd.{v,v})))) - -def isoExtAsSmallClosedTypeHom : - Core (AsSmall.{max u (v+2)} Grpd.{v,v}) - ⥤ ∫(toCoreAsSmallEquiv (asSmallClosedType.{v, max u (v + 2)})) where - obj X := objMk ⟨⟨⟩⟩ ⟨AsSmall.up.obj.{_,_,v+1} (AsSmall.down.obj X.of)⟩ - map {X Y} F := homMk (𝟙 _) ⟨{ - hom := AsSmall.up.map.{_,_,v+1} (AsSmall.down.map F.iso.hom) - inv := AsSmall.up.map.{_,_,v+1} (AsSmall.down.map (F.iso.inv)) - hom_inv_id := by - simp only [← Functor.map_comp, Iso.hom_inv_id] - rfl - inv_hom_id := by - simp only [← Functor.map_comp, Iso.inv_hom_id] - rfl }⟩ - -def isoExtAsSmallClosedTypeInv : - ∫(toCoreAsSmallEquiv (asSmallClosedType.{v, max u (v + 2)})) ⥤ - Core (AsSmall.{max u (v+2)} Grpd.{v,v}) where - obj X := ⟨AsSmall.up.obj (AsSmall.down.obj.{_,_,v+1} X.fiber.of)⟩ - map {X Y} F := ⟨{ - hom := AsSmall.up.map.{_,_,max u (v+2)} - (AsSmall.down.map F.fiber.iso.hom) - inv := AsSmall.up.map.{_,_,max u (v+2)} - (AsSmall.down.map F.fiber.iso.inv) - hom_inv_id := by - simp only [← Functor.map_comp, Iso.hom_inv_id] - rfl - inv_hom_id := by - simp only [← Functor.map_comp, Iso.inv_hom_id] - rfl }⟩ - -def isoExtAsSmallClosedType : - Ty.{v,max u (v+2)} - ≅ U.{v+1,max u (v+2)}.ext U.asSmallClosedType.{v, max u (v+2)} where - hom := (Grpd.homOf isoExtAsSmallClosedTypeHom.{v,u}) - inv := (Grpd.homOf isoExtAsSmallClosedTypeInv.{v,u}) - hom_inv_id := rfl - inv_hom_id := rfl - -end U - -def liftSeqObjs (i : Nat) (h : i < 4) : Universe Grpd.IsIsofibration.{4} := - match i with - | 0 => U.{0,4} - | 1 => U.{1,4} - | 2 => U.{2,4} - | 3 => U.{3,4} - | (n+4) => by omega - --- TODO: rename UHom to Universe.Lift -def lift : UHom U.{v, max u (v+2)} U.{v+1, max u (v+2)} := - @UHom.ofTyIsoExt _ _ _ _ _ _ - { mapTy := U.liftTy.{v,max u (v+2)} - mapTm := U.liftTm - pb := IsPullback.liftTm_isPullback } - asSmallClosedType - isoExtAsSmallClosedType.{v,u} - -def liftSeqHomSucc' (i : Nat) (h : i < 3) : - UHom (liftSeqObjs i (by omega)) (liftSeqObjs (i + 1) (by omega)) := - match i with - | 0 => lift.{0,4} - | 1 => lift.{1,4} - | 2 => lift.{2,4} - | (n+3) => by omega - -/-- - The groupoid natural model with three nested representable universes - within the ambient natural model. --/ -def liftSeq : UHomSeq Grpd.IsIsofibration.{4} where - length := 3 - objs := liftSeqObjs - homSucc' := liftSeqHomSucc' - -open CategoryTheory Opposite - -section - -variable {Γ : Grpd} {C : Type (v+1)} [Category.{v} C] {Δ : Grpd} (σ : Δ ⟶ Γ) - -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 - apply (U.disp_pullback A).hom_ext - · rw [substWk_var] - simp [var, Grpd.comp_eq_comp] - rw [← toCoreAsSmallEquiv_symm_apply_comp_left, Functor.assoc, pre_toPGrpd, - map_eqToHom_toPGrpd] - · rw [substWk_disp] - simp [Grpd.comp_eq_comp, Functor.assoc] - erw [pre_comp_forget, ← Functor.assoc, map_forget] - -@[simp] theorem sec_eq {Γ : Ctx} (α : Γ ⟶ U.{v}.Tm) (A : Γ ⟶ U.{v}.Ty) (hα : α ≫ U.tp = A) : - U.sec _ α hα = sec (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv α) - (by rw [← hα, Grpd.comp_eq_comp, tp, toCoreAsSmallEquiv_apply_comp_right]) := by - apply (U.disp_pullback _).hom_ext - . erw [Universe.sec_var, U_var, var, Grpd.comp_eq_comp, - ← toCoreAsSmallEquiv_symm_apply_comp_left, Equiv.eq_symm_apply, sec_toPGrpd] - rfl - . rw [sec_disp] - rfl - -namespace PtpEquiv - -variable (AB : Γ ⟶ U.{v}.Ptp.obj (Ctx.coreAsSmall C)) - -/-- -A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` -is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, -thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. -`PtpEquiv.fst` is the `A` in this pair. --/ -def fst : Γ ⥤ Grpd.{v,v} := - toCoreAsSmallEquiv (Universe.PtpEquiv.fst U AB) - -variable (A := fst AB) (hA : A = fst AB := by rfl) - -/-- -A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` -is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, -thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. -`PtpEquiv.snd` is the `B` in this pair. --/ -def snd : ∫A ⥤ C := - toCoreAsSmallEquiv (Universe.PtpEquiv.snd U AB (toCoreAsSmallEquiv.symm A) (by - simp [Universe.PtpEquiv.fst, hA, fst])) - -nonrec theorem fst_comp_left : fst (σ ≫ AB) = σ ⋙ fst AB := by - dsimp only [fst] - rw [PtpEquiv.fst_comp_left, ← toCoreAsSmallEquiv_apply_comp_left, Grpd.comp_eq_comp] - -theorem fst_comp_right {D : Type (v + 1)} [Category.{v, v + 1} D] (F : C ⥤ D) : - fst (AB ≫ U.Ptp.map (Ctx.coreAsSmallFunctor F)) = fst AB := by - dsimp only [fst] - rw [Universe.PtpEquiv.fst_comp_right] - -nonrec theorem snd_comp_left : snd (σ ≫ AB) (σ ⋙ A) (by rw [hA, fst_comp_left]) = - map (eqToHom (by rw [hA])) ⋙ pre _ σ ⋙ snd AB := by - dsimp only [snd] - erw [PtpEquiv.snd_comp_left _ rfl - (by simp [toCoreAsSmallEquiv_symm_apply_comp_left, Grpd.comp_eq_comp, hA, fst]), - toCoreAsSmallEquiv_apply_comp_left] - subst hA - simp [map_id_eq, substWk_eq]; rfl - -/-- -A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` -is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, -thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. -`PtpEquiv.mk` constructs such a map `AB` from such a pair `A` and `B`. --/ -def mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : - Γ ⟶ U.{v}.Ptp.obj (Ctx.coreAsSmall C) := - Universe.PtpEquiv.mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B) - -theorem hext (AB1 AB2 : Γ ⟶ U.{v}.Ptp.obj Ty.{v}) (hfst : fst AB1 = fst AB2) - (hsnd : HEq (snd AB1) (snd AB2)) : AB1 = AB2 := by - have hfst' : Universe.PtpEquiv.fst U AB1 = Universe.PtpEquiv.fst U AB2 := by - dsimp [fst] at hfst - aesop - apply Universe.PtpEquiv.ext U (Universe.PtpEquiv.fst U AB1) ?_ hfst' ?_ - · simp - · dsimp only [snd] at hsnd - apply toCoreAsSmallEquiv.injective - conv => right; rw! (castMode := .all) [hfst'] - simp [← heq_eq_eq] - exact hsnd - -@[simp] -lemma fst_mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : - fst (mk A B) = A := by - simp [fst, mk, Universe.PtpEquiv.fst_mk] - -lemma Grpd.eqToHom_comp_heq {A B : Grpd} {C : Type*} [Category C] - (h : A = B) (F : B ⥤ C) : eqToHom h ⋙ F ≍ F := by - subst h - simp [Grpd.id_eq_id, Functor.id_comp] - -lemma snd_mk (A A' : Γ ⥤ Grpd.{v,v}) (hA : A = A') (B : ∫(A) ⥤ C) : - snd (mk A B) A' (by rw [fst_mk, hA]) = map (eqToHom hA.symm) ⋙ B := by - dsimp only [snd, mk] - subst hA - rw [Universe.PtpEquiv.snd_mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B)] - erw [Equiv.apply_symm_apply toCoreAsSmallEquiv B] - simp [map_id_eq] - -lemma snd_mk_heq (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : - snd (mk A B) ≍ B := by - simp [snd_mk, map_eqToHom_comp_heq] - -end PtpEquiv - -def compDom := U.{v}.uvPolyTp.compDom U.{v}.uvPolyTp - -@[simp] -abbrev compP : compDom.{v} ⟶ U.{v}.Ptp.obj Ty.{v} := - Universe.compP U U - -namespace compDom - -variable (ab : (Γ) ⟶ compDom.{v}) - -/-- Universal property of `compDom`, decomposition (part 1). - -A map `ab : (Γ) ⟶ compDom` is equivalently three functors -`fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `fst : Γ ⥤ PGrpd` -is `(a : A)` in `(a : A) × (b : B a)`. --/ -def fst : Γ ⥤ PGrpd.{v,v} := - toCoreAsSmallEquiv (Universe.compDomEquiv.fst ab) - -/-- Universal property of `compDom`, decomposition (part 2). - -A map `ab : (Γ) ⟶ compDom` is equivalently three functors -`fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `dependent : Γ ⥤ Grpd` -is `B : A → Type` in `(a : A) × (b : B a)`. --/ -def dependent (A := fst ab ⋙ PGrpd.forgetToGrpd) (eq : fst ab ⋙ PGrpd.forgetToGrpd = A := by rfl) : - ∫(A) ⥤ Grpd.{v,v} := - toCoreAsSmallEquiv (Universe.compDomEquiv.dependent ab (toCoreAsSmallEquiv.symm A) (by - simp only [U_Ty, U_Tm, compDomEquiv.fst, U_tp, ← eq] - erw [toCoreAsSmallEquiv_symm_apply_comp_right] - simp [fst]; rfl)) - -/-- Universal property of `compDom`, decomposition (part 3). - -A map `ab : (Γ) ⟶ compDom` is equivalently three functors -`fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `snd : Γ ⥤ PGrpd` -is `(b : B a)` in `(a : A) × (b : B a)`. --/ -def snd : Γ ⥤ PGrpd.{v,v} := - toCoreAsSmallEquiv (Universe.compDomEquiv.snd ab) - -/-- Universal property of `compDom`, decomposition (part 4). - -A map `ab : (Γ) ⟶ compDom` is equivalently three functors -`fst, dependent, snd` such that `snd_forgetToGrpd`. -The equation `snd_forgetToGrpd` 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_forgetToGrpd : snd ab ⋙ PGrpd.forgetToGrpd = sec _ (fst ab) rfl ⋙ (dependent ab) := by - erw [← toCoreAsSmallEquiv_apply_comp_right, ← Grpd.comp_eq_comp, - Universe.compDomEquiv.snd_tp ab, sec_eq] - rfl - -/-- Universal property of `compDom`, constructing a map into `compDom`. -/ -def mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) - (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) - (B : ∫(A) ⥤ Grpd.{v,v}) - (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : - Γ ⟶ compDom.{v} := - Universe.compDomEquiv.mk (toCoreAsSmallEquiv.symm α) (A := toCoreAsSmallEquiv.symm A) - (by rw [← hA, toCoreAsSmallEquiv_symm_apply_comp_right]; rfl) - (toCoreAsSmallEquiv.symm B) (toCoreAsSmallEquiv.symm β) - (by - dsimp [U_tp, tp, Grpd.comp_eq_comp] - rw [← toCoreAsSmallEquiv_symm_apply_comp_right β PGrpd.forgetToGrpd, h, - toCoreAsSmallEquiv_symm_apply_comp_left] - congr 1 - simp only [sec_eq, Equiv.apply_symm_apply] - rw! (castMode := .all) [toCoreAsSmallEquiv.apply_symm_apply] - ) - -theorem fst_forgetToGrpd : fst ab ⋙ PGrpd.forgetToGrpd = - U.PtpEquiv.fst (ab ≫ compP.{v}) := by - erw [U.PtpEquiv.fst, ← compDomEquiv.fst_tp ab, ← toCoreAsSmallEquiv_apply_comp_right] - rfl - -theorem dependent_eq (A := fst ab ⋙ PGrpd.forgetToGrpd) - (eq : fst ab ⋙ PGrpd.forgetToGrpd = A := by rfl) : dependent ab A eq = - map (eqToHom (by rw [← eq, fst_forgetToGrpd])) ⋙ U.PtpEquiv.snd (ab ≫ compP.{v}) := by - dsimp only [dependent, PtpEquiv.snd] - rw [Universe.compDomEquiv.dependent_eq _ _ _, ← toCoreAsSmallEquiv_apply_comp_left] - subst eq - rw! [← fst_forgetToGrpd] - simp [map_id_eq] - -theorem dependent_heq : HEq (dependent ab) (U.PtpEquiv.snd (ab ≫ compP.{v})) := by - rw [dependent_eq] - apply Functor.precomp_heq_of_heq_id - · rw [fst_forgetToGrpd] - · rw [fst_forgetToGrpd] - · apply map_eqToHom_heq_id_cod - -theorem fst_comp : fst (σ ≫ ab) = σ ⋙ fst ab := by - dsimp only [fst] - rw [Universe.compDomEquiv.fst_comp, Grpd.comp_eq_comp, - toCoreAsSmallEquiv_apply_comp_left] - -theorem dependent_comp : dependent (σ ≫ ab) = - map (eqToHom (by rw [fst_comp, Functor.assoc])) - ⋙ pre _ σ ⋙ dependent ab := by - rw [dependent, dependent, - ← Universe.compDomEquiv.comp_dependent (eq1 := rfl) - (eq2 := by erw [← compDomEquiv.fst_comp_assoc, fst, toCoreAsSmallEquiv.eq_symm_apply]; rfl), - substWk_eq] - rfl - -theorem snd_comp : snd (σ ≫ ab) = σ ⋙ snd ab := by - dsimp only [snd] - rw [Universe.compDomEquiv.snd_comp, Grpd.comp_eq_comp, - toCoreAsSmallEquiv_apply_comp_left] - -/-- First component of the computation rule for `mk`. -/ -theorem fst_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) - (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) - (B : ∫(A) ⥤ Grpd.{v,v}) - (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : - fst (mk α A hA B β h) = α := by - simp [fst, mk, Universe.compDomEquiv.fst_mk] - -/-- Second component of the computation rule for `mk`. -/ -theorem dependent_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) - (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) - (B : ∫(A) ⥤ Grpd.{v,v}) - (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : - dependent (mk α A hA B β h) = map (eqToHom (by subst hA; rw [fst_mk])) ⋙ B := by - dsimp [dependent, mk] - rw [Equiv.apply_eq_iff_eq_symm_apply] - rw [compDomEquiv.dependent_mk] - · rw [toCoreAsSmallEquiv_symm_apply_comp_left] - erw [eqToHom_eq_homOf_map] - rfl - · simp [fst, compDomEquiv.fst_mk, hA] - -/-- Second component of the computation rule for `mk`. -/ -theorem snd_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) - (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) - (B : ∫(A) ⥤ Grpd.{v,v}) - (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : - snd (mk α A hA B β h) = β := by - dsimp [snd, mk] - rw [Universe.compDomEquiv.snd_mk] - simp - -theorem ext (ab1 ab2 : Γ ⟶ U.compDom.{v}) - (hfst : fst ab1 = fst ab2) - (hdependent : dependent ab1 = map (eqToHom (by rw [hfst])) ⋙ dependent ab2) - (hsnd : snd ab1 = snd ab2) : ab1 = ab2 := by - dsimp only [compDom] at ab1 - have h1 : compDomEquiv.fst ab1 = compDomEquiv.fst ab2 := by - apply toCoreAsSmallEquiv.injective - assumption - fapply compDomEquiv.ext rfl h1 - · dsimp [dependent, fst] at hdependent - apply toCoreAsSmallEquiv.injective - convert hdependent - · rw [toCoreAsSmallEquiv_symm_apply_comp_right] - simp; rfl - rw! (castMode := .all) [toCoreAsSmallEquiv_symm_apply_comp_right, - Equiv.symm_apply_apply, h1, hfst] - simp [map_id_eq] - congr 1 - simp [← heq_eq_eq] - rfl - · apply toCoreAsSmallEquiv.injective - assumption - -theorem hext (ab1 ab2 : Γ ⟶ U.compDom.{v}) - (hfst : fst ab1 = fst ab2) (hdependent : HEq (dependent ab1) (dependent ab2)) - (hsnd : snd ab1 = snd ab2) : ab1 = ab2 := by - apply ext - · rw! [hdependent] - simp [← heq_eq_eq] - conv => right; rw! (castMode := .all) [hfst] - simp [map_id_eq] - · assumption - · assumption - -end compDom - -end U -end - -end GroupoidModel - -end diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index df92695e..a252ce84 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -1,5 +1,4 @@ -import HoTTLean.Groupoids.NaturalModelBase -import HoTTLean.Model.NaturalModel +import HoTTLean.Groupoids.UnstructuredModel import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone universe v u v₁ u₁ v₂ u₂ v₃ u₃ @@ -8,7 +7,7 @@ noncomputable section namespace GroupoidModel -open CategoryTheory NaturalModel Universe Opposite Functor.Groupoidal PGrpd +open CategoryTheory UnstructuredModel Universe Opposite Functor.Groupoidal PGrpd attribute [local simp] eqToHom_map Grpd.id_eq_id Grpd.comp_eq_comp Functor.id_comp @@ -450,6 +449,14 @@ variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B @[simps] def fstAux : sigma A B ⟶ A where app x := Grpd.homOf forget +lemma fstAux_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : fstAux (pre A σ ⋙ B) = + eqToHom (sigma_naturality ..).symm ≫ Functor.whiskerLeft σ (fstAux B) := by + ext + simp only [sigma_obj, Functor.comp_obj, fstAux_app, NatTrans.comp_app, eqToHom_app, + Functor.whiskerLeft_app, ← heq_eq_eq, heq_eqToHom_comp_iff] + congr + all_goals rw [← Functor.assoc, ι_comp_pre] + def fstAux' : ∫(sigma A B) ⥤ ∫(A) := map (fstAux B) @@ -462,6 +469,12 @@ theorem fst_forgetToGrpd : fst B ⋙ forgetToGrpd = forget ⋙ A := by rw [Functor.assoc, (Functor.Groupoidal.isPullback A).comm_sq, ← Functor.assoc, map_forget] +lemma fst_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : + fst (pre A σ ⋙ B) = map (eqToHom (sigma_naturality B σ).symm) ⋙ pre (sigma A B) σ ⋙ fst B := by + simp [fst, fstAux'] + rw [fstAux_comp, map_comp_eq, ← pre_toPGrpd] + rfl -- FIXME: heavy rfl + end section @@ -504,9 +517,22 @@ theorem assocHom_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : 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 + def snd : ∫(sigma A B) ⥤ PGrpd := assoc B ⋙ toPGrpd B +lemma snd_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : snd (A := σ ⋙ A) (pre A σ ⋙ B) = + map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ ⋙ snd B := by + dsimp [snd] + have : toPGrpd (pre A σ ⋙ B) = pre B (pre A σ) ⋙ toPGrpd B := rfl + simp only [this, ← Functor.assoc, assoc_pre] + theorem ι_sigma_comp_map_fstAux (x) : ι (sigma A B) x ⋙ map (fstAux B) = forget ⋙ ι A x := by apply FunctorTo.hext @@ -604,6 +630,14 @@ def fst' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ fst B @[inherit_doc fst'] theorem fst'_forgetToGrpd : fst' B αβ hαβ ⋙ forgetToGrpd = A := rfl +lemma fst'_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : + fst' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by simp [Functor.assoc, hαβ, sigma_naturality]) = + σ ⋙ fst' B αβ hαβ := by + dsimp [fst'] + conv => right; rw [← Functor.assoc, Functor.Groupoidal.sec_naturality, Functor.assoc] + rw! [fst_comp, ← sigma_naturality] + simp [map_id_eq] + @[inherit_doc fst'] def dependent' : ∫(fst' B αβ hαβ ⋙ forgetToGrpd) ⥤ Grpd := map (eqToHom rfl) ⋙ B @@ -615,6 +649,15 @@ variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B @[inherit_doc fst'] def snd' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ snd B +lemma snd'_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : + snd' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by rw [Functor.assoc, hαβ, sigma_naturality]) = + σ ⋙ snd' B αβ hαβ := by + dsimp [snd'] + conv => right; rw [← Functor.assoc, sec_naturality] + rw! [snd_comp, ← sigma_naturality] + simp [map_id_eq] + rfl + @[simp] theorem fst'_obj_base {x} : ((fst' B αβ hαβ).obj x).base = A.obj x := rfl @@ -791,209 +834,187 @@ end FunctorOperation open FunctorOperation -/-- -Behavior of the Σ-type former (a natural transformation) on an input. -By Yoneda, "an input" is the same as a map from a representable into the domain. --/ -def USig.Sig_app {Γ : Ctx} - (AB : Γ ⟶ U.{v}.Ptp.obj U.{v}.Ty) : - Γ ⟶ U.{v}.Ty := - toCoreAsSmallEquiv.symm (sigma _ (U.PtpEquiv.snd AB)) +section + +def USig.Sig {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := + toCoreAsSmallEquiv.symm (sigma _ (toCoreAsSmallEquiv B)) /-- Naturality for the formation rule for Σ-types. -Also known as Beck-Chevalley +Also known as Beck-Chevalley. -/ -theorem USig.Sig_naturality {Γ Δ : Ctx} (σ : Δ ⟶ Γ) - (AB : Γ ⟶ U.{v}.Ptp.obj U.{v}.Ty) : - USig.Sig_app ((σ) ≫ AB) = (σ) ≫ USig.Sig_app AB := by - dsimp only [USig.Sig_app] - slice_rhs 1 2 => rw [Grpd.comp_eq_comp] +theorem USig.Sig_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} + (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) : + USig.Sig (U.substWk σ A σA eq ≫ B) = σ ≫ USig.Sig B := by + simp only [USig.Sig, Grpd.comp_eq_comp] rw [← toCoreAsSmallEquiv_symm_apply_comp_left] - rw [sigma_naturality] - -- note the order of rewrite is first the fiber, then the base - -- this allows rw! to cast the proof in the `eqToHom` - conv => left; rw! [U.PtpEquiv.fst_comp_left] - rw [U.PtpEquiv.snd_comp_left] congr 1 - simp [map_id_eq, Functor.id_comp] - -/-- The formation rule for Σ-types for the ambient natural model `base` - If possible, don't use NatTrans.app on this, - instead precompose it with maps from representables. --/ -def USig.Sig : U.{v}.Ptp.obj U.{v}.Ty ⟶ U.{v}.Ty := - ofYoneda USig.Sig_app USig.Sig_naturality - -lemma USig.Sig_app_eq {Γ : Ctx} (AB : Γ ⟶ _) : AB ≫ USig.Sig = - USig.Sig_app AB := by - simp [USig.Sig] + rw [sigma_naturality] + subst eq + simp only [Grpd.comp_eq_comp] + conv => left; right; rw! [toCoreAsSmallEquiv_apply_comp_left] + rw! (castMode := .all) [toCoreAsSmallEquiv_apply_comp_left] + simp [U.substWk_eq, map_id_eq] + rfl -open U.compDom +lemma USig.pair_aux {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + toCoreAsSmallEquiv b ⋙ forgetToGrpd = + sec (toCoreAsSmallEquiv a ⋙ forgetToGrpd) (toCoreAsSmallEquiv a) rfl ⋙ + map (eqToHom (by rw [← a_tp, ← toCoreAsSmallEquiv_apply_comp_right]; rfl)) ⋙ + toCoreAsSmallEquiv B := by + rw [← toCoreAsSmallEquiv_apply_comp_right, ← toCoreAsSmallEquiv_apply_comp_left, + ← toCoreAsSmallEquiv_apply_comp_left] + congr 1 + simp only [Grpd.comp_eq_comp, U.tp] at b_tp + rw [b_tp] + subst a_tp + simp [map_id_eq] + rfl -def USig.pair_app {Γ : Ctx} (ab : Γ ⟶ U.{v}.uvPolyTp.compDom U.{v}.uvPolyTp) : +def USig.pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : Γ ⟶ U.{v}.Tm := - toCoreAsSmallEquiv.symm (pair _ _ _ (snd_forgetToGrpd ab)) - -theorem USig.pair_naturality {Γ Δ : Ctx} (f : Δ ⟶ Γ) - (ab : Γ ⟶ U.compDom.{v}) : - USig.pair_app ((f) ≫ ab) = (f) ≫ USig.pair_app ab := by - dsimp only [USig.pair_app] - slice_rhs 1 2 => rw [Grpd.comp_eq_comp] - rw [← toCoreAsSmallEquiv_symm_apply_comp_left] - rw [FunctorOperation.pair_naturality] - -- Like with `USig.Sig_naturality` rw from inside to outside (w.r.t type dependency) - rw! (castMode := .all) [dependent_comp, snd_comp, fst_comp] - simp [map_id_eq, Functor.id_comp] + toCoreAsSmallEquiv.symm <| + FunctorOperation.pair (toCoreAsSmallEquiv a) (toCoreAsSmallEquiv b) + (map (eqToHom (by + rw [← a_tp, ← toCoreAsSmallEquiv_apply_comp_right, Grpd.comp_eq_comp, U.tp])) ⋙ + toCoreAsSmallEquiv B) <| pair_aux B a a_tp b b_tp + +theorem USig.pair_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} + (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + USig.pair (U.substWk σ A σA eq ≫ B) (σ ≫ a) (by cat_disch) (σ ≫ b) + (by rw! [Category.assoc, b_tp, comp_sec_assoc]) = σ ≫ USig.pair B a a_tp b b_tp := by + dsimp [pair] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, FunctorOperation.pair_naturality] + congr 2 + slice_rhs 2 3 => rw [← toCoreAsSmallEquiv_apply_comp_left] + subst a_tp eq + simp [← toCoreAsSmallEquiv_apply_comp_left, map_id_eq, U.substWk_eq] + rfl -def USig.pair : U.compDom.{v} ⟶ U.{v}.Tm := - ofYoneda USig.pair_app USig.pair_naturality +lemma USig.pair_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + USig.pair B a a_tp b b_tp ≫ U.tp = USig.Sig B := by + dsimp [pair, Sig, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, FunctorOperation.pair_comp_forgetToGrpd, + ← toCoreAsSmallEquiv_apply_comp_left] + subst a_tp + congr 3 + convert_to Grpd.homOf (map (eqToHom _)) ≫ B = 𝟙 (U.ext (a ≫ U.tp)) ≫ B + rw [← eqToHom_eq_homOf_map] + simp -lemma USig.pair_comp_left {Γ : Ctx} (ab : Γ ⟶ _) : ab ≫ USig.pair = - USig.pair_app ab := by - simp [USig.pair] +lemma USig.fst_aux {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : + toCoreAsSmallEquiv s ⋙ forgetToGrpd = sigma (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv B) := by + dsimp only [U.tp, Grpd.comp_eq_comp, Sig] at s_tp + rw [← toCoreAsSmallEquiv_apply_comp_right, s_tp] + simp -theorem USig.pair_tp {Γ : Ctx} (ab : Γ ⟶ _) : pair_app ab ≫ U.tp = Sig_app (ab ≫ U.compP) := by - simp [pair_app, Sig_app] - erw [← toCoreAsSmallEquiv_symm_apply_comp_right, pair_comp_forgetToGrpd] - rw! (castMode := .all) [fst_forgetToGrpd, Grpd.comp_eq_comp] +def USig.fst {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : Γ ⟶ U.Tm.{v} := + toCoreAsSmallEquiv.symm <| FunctorOperation.sigma.fst' (toCoreAsSmallEquiv B) + (toCoreAsSmallEquiv s) <| fst_aux B s s_tp + +lemma USig.fst_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) + (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : + USig.fst (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = + σ ≫ USig.fst B s s_tp := by + dsimp [fst] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, ← sigma.fst'_comp] + subst eq + rw! [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] + simp [map_id_eq] rfl -namespace SigPullback - -open Limits +lemma USig.fst_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : + USig.fst B s s_tp ≫ U.tp = A := by + dsimp [fst, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, sigma.fst'_forgetToGrpd] + simp -section +def USig.snd {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : Γ ⟶ U.Tm.{v} := + toCoreAsSmallEquiv.symm <| FunctorOperation.sigma.snd' (toCoreAsSmallEquiv B) + (toCoreAsSmallEquiv s) <| fst_aux B s s_tp -section -variable {Γ : Ctx} (AB : Γ ⟶ U.Ptp.obj.{v} U.Ty.{v}) - (αβ : Γ ⟶ U.Tm.{v}) (hαβ : αβ ≫ U.tp = USig.Sig_app AB) - -include hαβ in -theorem toCoreAsSmallEquiv_forgetToGrpd : toCoreAsSmallEquiv αβ ⋙ forgetToGrpd - = sigma (U.PtpEquiv.fst AB) (U.PtpEquiv.snd AB) := by - erw [← toCoreAsSmallEquiv_apply_comp_right, - ← Grpd.comp_eq_comp, hαβ] - rw [USig.Sig_app, toCoreAsSmallEquiv.apply_symm_apply] - -def lift : Γ ⟶ U.compDom.{v} := - let β' := U.PtpEquiv.snd AB - let αβ' := toCoreAsSmallEquiv αβ - let hαβ' : toCoreAsSmallEquiv αβ ⋙ forgetToGrpd - = sigma (U.PtpEquiv.fst AB) (U.PtpEquiv.snd AB) := - toCoreAsSmallEquiv_forgetToGrpd _ _ hαβ - U.compDom.mk (sigma.fst' β' αβ' hαβ') _ rfl (sigma.dependent' β' αβ' hαβ') - (sigma.snd' β' αβ' hαβ') (sigma.snd'_forgetToGrpd β' αβ' hαβ') - -lemma fst_lift : fst (lift AB αβ hαβ) = - sigma.fst' (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) - (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by - simp [lift, fst_mk] - -lemma snd_lift : snd (lift AB αβ hαβ) = sigma.snd' - (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) - (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by - simp [lift, snd_mk] - -lemma dependent_lift : dependent (lift AB αβ hαβ) = - map (eqToHom (by rw [fst_lift AB αβ hαβ])) ⋙ sigma.dependent' - (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) - (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by - simp [lift, dependent_mk] - -theorem pair_app_lift : USig.pair_app (SigPullback.lift AB αβ hαβ) = αβ := by - rw [USig.pair_app, toCoreAsSmallEquiv.symm_apply_eq] - rw! [dependent_lift, snd_lift, fst_lift] - simp [eqToHom_refl, map_id_eq, sigma.eta] - -theorem lift_compP : lift.{v} AB αβ hαβ ≫ U.compP.{v} = AB := by - apply U.PtpEquiv.hext - · rw [← fst_forgetToGrpd] - dsimp only [lift] - rw [fst_mk, sigma.fst'_forgetToGrpd] - · apply HEq.trans (dependent_heq _).symm - rw [lift, dependent_mk] - dsimp [sigma.dependent'] - simp [map_id_eq, Functor.id_comp] - apply map_eqToHom_comp_heq - -theorem hom_ext (m n : Γ ⟶ U.compDom) - (hComp : m ≫ U.compP.{v} = n ≫ U.compP) - (hPair : m ≫ USig.pair = n ≫ USig.pair) : - m = n := by - have h : (pair (fst m) (snd m) (dependent m) - (snd_forgetToGrpd m)) = - (pair (fst n) (snd n) (dependent n) - (snd_forgetToGrpd n)) := - calc _ - _ = toCoreAsSmallEquiv (m ≫ USig.pair) := by - simp [USig.pair_comp_left m, USig.pair_app] - _ = toCoreAsSmallEquiv (n ≫ USig.pair) := by rw [hPair] - _ = _ := by - simp [USig.pair_comp_left n, USig.pair_app] - have : fst m ⋙ forgetToGrpd = fst n ⋙ forgetToGrpd := by - rw [fst_forgetToGrpd, fst_forgetToGrpd, hComp] - have hdep : HEq (dependent m) (dependent n) := by - refine (dependent_heq _).trans - $ HEq.trans ?_ $ (dependent_heq _).symm - rw [hComp] - fapply U.compDom.hext - · calc fst m - _ = sigma.fst' _ (FunctorOperation.pair (fst m) (snd m) - (dependent m) (snd_forgetToGrpd m)) _ := - (sigma.fst'_pair _).symm - _ = sigma.fst' _ (FunctorOperation.pair (fst n) (snd n) - (dependent n) (snd_forgetToGrpd n)) _ := by - rw! [h] - congr! 1 - _ = fst n := sigma.fst'_pair _ - · exact hdep - · calc snd m - _ = sigma.snd' _ (FunctorOperation.pair (fst m) (snd m) - (dependent m) (snd_forgetToGrpd m)) _ := - (sigma.snd'_pair _).symm - _ = sigma.snd' _ (FunctorOperation.pair (fst n) (snd n) - (dependent n) (snd_forgetToGrpd n)) _ := by - rw! [h] - congr! - _ = snd n := sigma.snd'_pair _ - -theorem uniq (m : Γ ⟶ U.compDom) - (hl : USig.pair_app m = αβ) - (hr : m ≫ U.compP = AB) : - m = lift AB αβ hαβ := by - apply hom_ext - · rw [hr, lift_compP] - · rw [USig.pair_comp_left, hl, USig.pair_comp_left, pair_app_lift] - -end -end +lemma USig.snd_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) + (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : + USig.snd (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = + σ ≫ USig.snd B s s_tp := by + dsimp [snd] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left] + congr 1 + rw [← sigma.snd'_comp] + subst eq + congr 1 + rw [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] + simp [map_id_eq] + rfl -end SigPullback +def USig.snd_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : + USig.snd B s s_tp ≫ U.tp = U.sec A (USig.fst B s s_tp) (fst_tp ..) ≫ B := by + dsimp [snd, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, sigma.snd'_forgetToGrpd, + toCoreAsSmallEquiv.symm_apply_eq, toCoreAsSmallEquiv_apply_comp_left] + simp [sigma.dependent', map_id_eq] + rfl -theorem USig.isPullback : IsPullback USig.pair U.compP.{v,u} U.tp.{v,u} USig.Sig := - ofYoneda_isPullback _ _ _ _ _ _ (fun ab => USig.pair_tp ab) - (fun αβ AB hαβ => SigPullback.lift AB αβ hαβ) - (fun αβ AB hαβ => SigPullback.pair_app_lift AB αβ hαβ) - (fun αβ AB hαβ => SigPullback.lift_compP.{v,u} AB αβ hαβ) - (fun αβ AB hαβ m hl hr => SigPullback.uniq.{v,u} AB αβ hαβ m hl hr) +lemma USig.fst_pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + fst B (USig.pair B a a_tp b b_tp) (pair_tp ..) = a := by + dsimp [fst, pair] + rw [toCoreAsSmallEquiv.symm_apply_eq] + subst a_tp + simp only [Grpd.comp_eq_comp, eqToHom_refl, map_id_eq, Cat.of_α, Functor.id_comp, + Equiv.apply_symm_apply] + exact sigma.fst'_pair (α := toCoreAsSmallEquiv a) (β := toCoreAsSmallEquiv b) + (B := toCoreAsSmallEquiv B) (by rw [pair_aux B a rfl b b_tp]; simp [map_id_eq]; rfl) + +lemma USig.snd_pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + USig.snd B (USig.pair B a a_tp b b_tp) (pair_tp ..) = b := by + dsimp [snd, pair] + rw [toCoreAsSmallEquiv.symm_apply_eq] + subst a_tp + simp only [Grpd.comp_eq_comp, eqToHom_refl, map_id_eq, Cat.of_α, Functor.id_comp, + Equiv.apply_symm_apply] + exact sigma.snd'_pair (α := toCoreAsSmallEquiv a) (β := toCoreAsSmallEquiv b) + (B := toCoreAsSmallEquiv B) (by rw [pair_aux B a rfl b b_tp]; simp [map_id_eq]; rfl) + +lemma USig.eta {Γ : Grpd} {A : Γ ⟶ U.Ty} (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) + (s_tp : s ≫ U.tp = USig.Sig B) : + USig.pair B (USig.fst B s s_tp) (fst_tp ..) (USig.snd B s s_tp) (snd_tp ..) = s := by + dsimp [pair] + rw [toCoreAsSmallEquiv.symm_apply_eq] + have h := FunctorOperation.sigma.eta (toCoreAsSmallEquiv B) (toCoreAsSmallEquiv s) + (by rwa [fst_aux]) + simp only [map_id_eq, Cat.of_α, Functor.id_comp] + rw [← h] + congr 1 + simp [sigma.dependent', map_id_eq] -def USig : Universe.Sigma U.{v} where +def USig : Universe.PolymorphicSigma U.{v} U.{v} U.{v} where Sig := USig.Sig + Sig_comp := USig.Sig_comp pair := USig.pair - Sig_pullback := USig.isPullback - -def liftSeqSigs' (i : ℕ) (ilen : i < 4) : - Universe.Sigma (liftSeqObjs i ilen) := - match i with - | 0 => USig.{0, 4} - | 1 => USig.{1, 4} - | 2 => USig.{2, 4} - | 3 => USig.{3, 4} - | (n+4) => by omega - -instance liftSeqSigma : liftSeq.SigSeq where - nmSig := liftSeqSigs' + pair_comp := USig.pair_comp + pair_tp := USig.pair_tp + fst := USig.fst + fst_comp := USig.fst_comp + fst_tp := USig.fst_tp + snd := USig.snd + snd_comp := USig.snd_comp + snd_tp := USig.snd_tp + fst_pair := USig.fst_pair + snd_pair := USig.snd_pair + eta := USig.eta + +end end GroupoidModel end diff --git a/HoTTLean/Groupoids/SigmaBackup.lean b/HoTTLean/Groupoids/SigmaBackup.lean new file mode 100644 index 00000000..df92695e --- /dev/null +++ b/HoTTLean/Groupoids/SigmaBackup.lean @@ -0,0 +1,999 @@ +import HoTTLean.Groupoids.NaturalModelBase +import HoTTLean.Model.NaturalModel +import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone + +universe v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section + +namespace GroupoidModel + +open CategoryTheory NaturalModel Universe Opposite Functor.Groupoidal PGrpd + +attribute [local simp] eqToHom_map Grpd.id_eq_id Grpd.comp_eq_comp Functor.id_comp + +namespace FunctorOperation + +section +variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} + (B : ∫ A ⥤ Grpd.{v₁,u₁}) (x : Γ) +/-- +For a point `x : Γ`, `(sigma A B).obj x` is the groupoidal Grothendieck + construction on the composition + `ι _ x ⋙ B : A.obj x ⥤ Groupoidal A ⥤ Grpd` +-/ +def sigmaObj : Grpd := Grpd.of (∫ι A x ⋙ B) + +variable {x} {y : Γ} (f : x ⟶ y) +/-- +For a morphism `f : x ⟶ y` in `Γ`, `(sigma A B).map y` is a +composition of functors. +The first functor `map (whiskerRight (ιNatTrans f) B)` +is an equivalence which replaces `ι A x` with the naturally +isomorphic `A.map f ⋙ ι A y`. +The second functor is the action of precomposing +`A.map f` with `ι A y ⋙ B` on the Grothendieck constructions. + + map ⋯ pre ⋯ + ∫ ι A x ⋙ B ⥤ ∫ A.map f ⋙ ι A y ⋙ B ⥤ ∫ ι A y ⋙ B +-/ +def sigmaMap : sigmaObj B x ⥤ sigmaObj B y := + map (Functor.whiskerRight (ιNatTrans f) B) ⋙ pre (ι A y ⋙ B) (A.map f) + +@[simp] theorem sigmaMap_obj_base (a) : + ((sigmaMap B f).obj a).base = (A.map f).obj a.base := + rfl + +@[simp] theorem sigmaMap_obj_fiber (a) : + ((sigmaMap B f).obj a).fiber = (B.map ((ιNatTrans f).app a.base)).obj (a.fiber) := rfl + +theorem ιNatTrans_app_base (a : sigmaObj B x) : ((ιNatTrans f).app a.base) = homMk f (𝟙 (A.map f).obj a.base) := + rfl + +@[simp] theorem sigmaMap_map_base {a b : sigmaObj B x} {p : a ⟶ b} : + ((sigmaMap B f).map p).base = (A.map f).map p.base := rfl + +theorem sigmaMap_map_fiber_aux {a b : sigmaObj B x} {p : a ⟶ b} : + (((ι A y ⋙ B)).map ((sigmaMap B f).map p).base).obj ((sigmaMap B f).obj a).fiber = + (B.map ((ιNatTrans f).app (base b))).obj (((ι A x ⋙ B).map p.base).obj a.fiber) := by + simp only [sigmaObj, sigmaMap, Functor.comp_obj, Functor.comp_map, pre_map_base, map_map_base, + pre_obj_fiber, map_obj_fiber, Functor.whiskerRight_app] + simp only [← Functor.comp_obj, ← Grpd.comp_eq_comp, ← Functor.map_comp] + congr 2 + exact ((ιNatTrans f).naturality p.base).symm + +@[simp] theorem sigmaMap_map_fiber {a b : sigmaObj B x} {p : a ⟶ b} : + ((sigmaMap B f).map p).fiber = + eqToHom (sigmaMap_map_fiber_aux B f) ≫ (B.map ((ιNatTrans f).app (base b))).map p.fiber := by + simp only [sigmaObj, sigmaMap, Functor.comp_obj, Functor.comp_map, + pre_map_fiber, map_map_fiber, Functor.whiskerRight_app] + +variable {B} + +@[simp] theorem sigmaMap_id_obj {p} : (sigmaMap B (𝟙 x)).obj p = p := by + apply hext + · simp [sigmaMap] + · simp [sigmaMap, Grpd.eqToHom_obj] + +@[simp] theorem sigmaMap_id_map {p1 p2} {hp2 : p2 = (sigmaMap B (𝟙 x)).obj p2} + (f : p1 ⟶ p2) : + (sigmaMap B (𝟙 x)).map f = + eqToHom (by simp) ≫ f ≫ eqToHom (by simp) := by + have h (a : A.obj x) : B.map ((ιNatTrans (𝟙 x)).app a) = + eqToHom (by simp) := + calc + B.map ((ιNatTrans (𝟙 x)).app a) + _ = B.map (eqToHom (by simp)) := by + rw [ιNatTrans_id_app] + _ = eqToHom (by simp) := by + simp + have h1 : B.map ((ι A x).map (eqToHom hp2).base) = eqToHom (by simp) := by + simp [sigmaObj, base_eqToHom] + fapply Hom.ext + · simp [sigmaObj, sigmaMap] + · simp [sigmaObj, sigmaMap_map_fiber, Functor.congr_hom (h p2.base) f.fiber, + Functor.congr_hom h1] + +@[simp] theorem sigmaMap_id : sigmaMap B (𝟙 x) = 𝟭 _ := by + apply CategoryTheory.Functor.ext + · intro p1 p2 f + simp + · intro p + simp + +variable {z : Γ} {f} {g : y ⟶ z} + +@[simp] theorem sigmaMap_comp_obj {p} : (sigmaMap B (f ≫ g)).obj p = + (sigmaMap B g).obj ((sigmaMap B f).obj p) := by + dsimp only [sigmaMap] + apply hext + · simp + · simp only [sigmaObj, Functor.comp_obj, pre_obj_fiber, map_obj_fiber, Functor.whiskerRight_app, + ιNatTrans_comp_app, Functor.map_comp, eqToHom_map, Grpd.comp_eq_comp, Grpd.eqToHom_obj, cast_heq_iff_heq, heq_eq_eq] + aesop_cat + +@[simp] theorem sigmaMap_comp_map {A : Γ ⥤ Grpd.{v₁,u₁}} + {B : ∫(A) ⥤ Grpd.{v₁,u₁}} {x y z : Γ} {f : x ⟶ y} {g : y ⟶ z} + {p q : sigmaObj B x} (hpq : p ⟶ q) + {h1 : (sigmaMap B (f ≫ g)).obj p = (sigmaMap B g).obj ((sigmaMap B f).obj p)} + {h2 : (sigmaMap B g).obj ((sigmaMap B f).obj q) = (sigmaMap B (f ≫ g)).obj q} + : (sigmaMap B (f ≫ g)).map hpq = + eqToHom h1 ≫ (sigmaMap B g).map ((sigmaMap B f).map hpq) ≫ eqToHom h2 := by + have h : B.map ((ιNatTrans (f ≫ g)).app q.base) = + B.map ((ιNatTrans f).app q.base) + ≫ B.map ((ιNatTrans g).app ((A.map f).obj q.base)) + ≫ eqToHom (by simp) := by simp + fapply Hom.hext + · simp only [sigmaObj, Grpd.coe_of, sigmaMap_obj_base, sigmaMap_map_base, Grpd.map_comp_map, + comp_base, base_eqToHom] + · have h3 : (ι A z ⋙ B).map (eqToHom h2).base + = eqToHom (by simp only [sigmaMap, Functor.comp_obj]; congr 3) := by + rw [base_eqToHom, eqToHom_map] + simp only [sigmaObj, Grpd.coe_of, sigmaMap_obj_base, Functor.comp_obj, sigmaMap_map_base, + Functor.comp_map, sigmaMap_obj_fiber, sigmaMap_map_fiber, Functor.congr_hom h, + Grpd.comp_eq_comp, eqToHom_trans_assoc, comp_base, Functor.Groupoidal.comp_fiber, + fiber_eqToHom, eqToHom_map, Functor.map_comp, Category.assoc, heq_eqToHom_comp_iff, + heq_comp_eqToHom_iff, eqToHom_comp_heq_iff, comp_eqToHom_heq_iff] + rw! (transparency := .default) [Functor.congr_hom h3] + simp only [sigmaObj, Functor.comp_obj, Functor.comp_map, heq_eqToHom_comp_iff, + heq_comp_eqToHom_iff, heq_eq_eq] + +theorem sigmaMap_comp : sigmaMap B (f ≫ g) = sigmaMap B f ⋙ sigmaMap B g := by + apply CategoryTheory.Functor.ext + · intro p q hpq + simp + · intro p + simp + +lemma sigmaMap_forget : sigmaMap B f ⋙ forget = forget ⋙ A.map f := rfl + +/-- The formation rule for Σ-types for the ambient natural model `base` + unfolded into operations between functors. + See `sigmaObj` and `sigmaMap` for the actions of this functor. + -/ +@[simps] def sigma (A : Γ ⥤ Grpd.{v₁,u₁}) + (B : ∫(A) ⥤ Grpd.{v₁,u₁}) : Γ ⥤ Grpd.{v₁,u₁} where + -- NOTE using Grpd.of here instead of earlier speeds things up + obj x := sigmaObj B x + map := sigmaMap B + map_id _ := sigmaMap_id + map_comp _ _ := sigmaMap_comp + +variable (B) {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) +theorem sigma_naturality_aux (x) : + ι (σ ⋙ A) x ⋙ pre A σ ⋙ B = ι A (σ.obj x) ⋙ B := by + rw [← ι_comp_pre] + rfl + +lemma whiskerRight_ιNatTrans_naturality {x y : Δ} (f : x ⟶ y) : + Functor.whiskerRight (ιNatTrans f) (pre A σ ⋙ B) = + eqToHom (sigma_naturality_aux B σ x) ≫ Functor.whiskerRight (ιNatTrans (σ.map f)) B ≫ + eqToHom (by simp [Functor.assoc, sigma_naturality_aux B σ y]) := by + aesop + +lemma sigma_naturality_obj (x) : + Grpd.of (∫ι A (σ.obj x) ⋙ B) + = Grpd.of (∫ι (σ ⋙ A) x ⋙ pre A σ ⋙ B) := by + rw [sigma_naturality_aux] + +lemma sigmaObj_naturality (x) : + sigmaObj B (σ.obj x) = sigmaObj (pre A σ ⋙ B) x := + sigma_naturality_obj _ _ _ + +lemma sigmaMap_naturality {x y : Δ} (f : x ⟶ y) : sigmaMap B (σ.map f) + = Grpd.homOf (map (eqToHom (sigma_naturality_aux B σ x).symm)) ≫ + sigmaMap (pre A σ ⋙ B) f ≫ + Grpd.homOf (map (eqToHom (sigma_naturality_aux B σ y))) := by + have : pre (ι A (σ.obj y) ⋙ B) (A.map (σ.map f)) + = map (eqToHom (by rw[← (sigma_naturality_aux B σ y)])) + ⋙ pre (ι (σ ⋙ A) y ⋙ pre A σ ⋙ B) (A.map (σ.map f)) + ⋙ map (eqToHom (sigma_naturality_aux B σ y)) := by + rw [pre_congr_functor] + dsimp [Grpd.homOf, sigmaMap, ← Functor.assoc] + rw [← map_comp_eq, whiskerRight_ιNatTrans_naturality] + simp [map_comp_eq, this, Functor.assoc] + +lemma sigmaMap_naturality_heq {x y : Δ} (f : x ⟶ y) : sigmaMap B (σ.map f) + ≍ sigmaMap (pre A σ ⋙ B) f := by + rw [sigmaMap_naturality] + simp only [sigmaObj, Functor.comp_obj, Grpd.homOf, + ← eqToHom_eq_homOf_map (sigma_naturality_aux B σ x).symm, + ← eqToHom_eq_homOf_map (sigma_naturality_aux B σ y)] + apply HEq.trans (eqToHom_comp_heq _ _) + apply HEq.trans (comp_eqToHom_heq _ _) + rfl + +-- NOTE formerly called `sigmaBeckChevalley` +theorem sigma_naturality : σ ⋙ sigma A B = sigma (σ ⋙ A) (pre A σ ⋙ B) := by + fapply CategoryTheory.Functor.hext + . apply sigmaObj_naturality + . apply sigmaMap_naturality_heq + +end + +section + +variable {Γ : Type u₂} [Category.{v₂} Γ] {α β : Γ ⥤ PGrpd.{v₁,u₁}} + {B : ∫(α ⋙ forgetToGrpd) ⥤ Grpd.{v₁,u₁}} + (h : β ⋙ forgetToGrpd = sec _ α rfl ⋙ B) + +def pairObjFiber (x : Γ) : sigmaObj B x := + objMk (objFiber α x) (objFiber' h x) + +@[simp] theorem pairObjFiber_base (x : Γ) : (pairObjFiber h x).base = objFiber α x := + rfl + +@[simp] theorem pairObjFiber_fiber (x : Γ) : + (pairObjFiber h x).fiber = (objFiber' h x) := + rfl + +theorem pairSectionMap_aux_aux {x y} (f : x ⟶ y) : + (ιNatTrans f).app (pairObjFiber h x).base + ≫ (ι _ y).map (mapFiber α f) + = (sec _ α rfl).map f := by + apply Hom.ext + · simp only [Functor.Groupoidal.comp_fiber, ιNatTrans_app_fiber, ι_obj_fiber, ι_map_fiber, + sec_map_fiber, mapFiber', mapFiber] + rw! (transparency := .default) [CategoryTheory.Functor.map_id, Category.id_comp] + simp [mapFiber'EqToHom] + · simp + +/-- + The left hand side + `mapPairSectionObjFiber h f` is an object in the fiber `sigma A B y` over `y` + The fiber itself consists of bundles, so `(mapPairSectionObjFiber h f).fiber` + is an object in the fiber `B a` for an `a` in the fiber `A y`. + But this `a` is isomorphic to `(pairSectionObjFiber y).base` + and the functor `(ι _ y ⋙ B).map (mapPoint α f)` + converts the data along this isomorphism. + + The right hand side is `(*)` in the diagram. + sec α B + Γ -------> ∫(A) ------------> Grpd + + x (B ⋙ sec α).obj x objPt' h x + | f (B ⋙ sec α).map f | - + V V | + y (B ⋙ sec α).obj y V + (*) +-/ +theorem pairMapFiber_aux {x y} (f : x ⟶ y) : + ((ι _ y ⋙ B).map (mapFiber α f)).obj ((sigmaMap B f).obj (pairObjFiber h x)).fiber = + ((sec _ α rfl ⋙ B).map f).obj (objFiber' h x) := by + simp only [Grpd.forgetToCat.eq_1, Functor.comp_obj, Functor.comp_map, + sigmaObj, sigmaMap, pre_obj_fiber, map_obj_fiber, Functor.whiskerRight_app] + rw [← Grpd.map_comp_obj, pairSectionMap_aux_aux] + rfl + +/-- +This can be thought of as the action of parallel transport on f +or perhaps the path over f, but defined within the fiber over y + + sigma A B x ∋ pairObjFiber h x + | - + | | + | sigma A B f | + | | + V V + sigma A B y ∋ PairMapFiber + _ ⟶ pairObjFiber h y +-/ +def pairMapFiber {x y : Γ} (f : x ⟶ y) : (sigmaMap B f).obj (pairObjFiber h x) + ⟶ (pairObjFiber h y : ∫(ι _ y ⋙ B)) := + homMk (mapFiber α f) (eqToHom (pairMapFiber_aux h f) ≫ mapFiber' h f) + +@[simp↓] theorem pairMapFiber_base {x y} (f : x ⟶ y) : + (pairMapFiber h f).base = mapFiber α f := + rfl + +/- +1. The first implicit argument to `Groupoidal.Hom.fiber` is `(α ⋙ forgetToGrpd).obj y`. + The global `simp` rule `Functor.comp_obj` (which normally fires before this) + rewrites that to `forgetToGrpd.obj (α.obj x)`, + and then this lemma no longer applies. + As a workaround, we instruct `simp` to apply this before visiting subterms. + +2. `@[simps! fiber]` on `pairMapFiber` generates a lemma + that refers to `Grothendieck.Hom.fiber` rather than `Groupoidal.Hom.fiber`, + so we write this by hand. -/ +@[simp↓] theorem pairMapFiber_fiber {x y} (f : x ⟶ y) : + (pairMapFiber h f).fiber = eqToHom (pairMapFiber_aux h f) ≫ mapFiber' h f := + rfl + +theorem pairMapFiber_id (x : Γ) : pairMapFiber h (𝟙 x) = eqToHom (by simp) := by + apply Hom.ext <;> simp [sigmaObj] + +theorem pairMapFiber_comp_aux_aux {x y z} (f : x ⟶ y) (g : y ⟶ z) : + ((ι _ z ⋙ B).map (mapFiber α g)).obj + (((ι _ z ⋙ B ⋙ Grpd.forgetToCat).map + (((sigmaMap B g).map (pairMapFiber h f))).base).obj + ((sigmaMap B g).obj (((sigmaMap B f).obj (pairObjFiber h x)))).fiber) + = ((sec _ α rfl ⋙ B).map f ≫ (sec _ α rfl ⋙ B).map g).obj (objFiber' h x) := by + have h1 : (sec _ α rfl ⋙ B).map f ≫ (sec _ α rfl ⋙ B).map g = (sec _ α rfl ⋙ B).map (f ≫ g) := by + rw [← Functor.map_comp] + rw [Functor.congr_obj h1, ← pairMapFiber_aux,mapFiber_comp, + Functor.map_comp, eqToHom_map, Grpd.comp_eq_comp] + simp only [Functor.comp_obj, Functor.map_comp, Grpd.eqToHom_obj] + congr 2 + have : (sigmaMap B g).obj ((sigmaMap B f).obj (pairObjFiber h x)) + = (sigmaMap B (f ≫ g)).obj (pairObjFiber h x) := by + rw [sigmaMap_comp] + rfl + rw [eq_cast_iff_heq] + congr + +theorem pairMapFiber_comp_aux {x y z} (f : x ⟶ y) (g : y ⟶ z) : + ((ι _ z ⋙ B).map (mapFiber α g)).map ((sigmaMap B g).map (pairMapFiber h f)).fiber + = eqToHom (pairMapFiber_comp_aux_aux h f g) + ≫ ((sec _ α rfl ⋙ B).map g).map (mapFiber' h f) + ≫ eqToHom (by rw [← pairMapFiber_aux]) := by + simp only [Functor.comp_map, sigmaObj, sigmaMap_map_fiber, + Functor.map_comp, eqToHom_map, Category.assoc, eqToHom_trans_assoc, + Grpd.map_comp_map', eqToHom_trans_assoc, eqToHom_comp_iff, comp_eqToHom_iff, + eqToHom_trans_assoc, Category.assoc, eqToHom_trans] + rw! [pairSectionMap_aux_aux] + simp only [pairMapFiber_fiber, Functor.map_comp, eqToHom_refl, Category.comp_id, eqToHom_map] + +-- TODO remove bleedings of `Grothendieck`, e.g. `Grothendieck.forget_obj` +theorem pairMapFiber_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : + (pairMapFiber h (f ≫ g)) = eqToHom (by simp) + ≫ (((sigma (α ⋙ forgetToGrpd) B).map g).map (pairMapFiber h f) ≫ pairMapFiber h g) := by + fapply Hom.ext + · simp [sigmaObj, - Functor.comp_obj, mapFiber] -- FIXME + · rw! (transparency := .default) [pairMapFiber_fiber, Functor.Groupoidal.comp_fiber, Functor.Groupoidal.comp_fiber, + fiber_eqToHom, eqToHom_map, pairMapFiber_comp_aux, + Functor.congr_hom (Functor.congr_hom h.symm g) (mapFiber' h f), mapFiber'_comp] + simp only [sigmaObj, pairMapFiber_fiber, mapFiber', eqToHom_trans_assoc, Category.assoc, + eqToHom_comp_iff, mapFiber'EqToHom] + simp only [← Category.assoc] + congr 1 + simp only [Grpd.coe_of, Grpd.eqToHom_hom, pairObjFiber_base, + Functor.comp_map, Grpd.comp_eq_comp, Category.assoc] + conv => right; right; simp only [← congrArg_cast_hom_left, cast_cast] + rw [conj_eqToHom_iff_heq] + · simp only [heq_cast_iff_heq, cast_heq_iff_heq] + congr 1 + · erw [Functor.congr_obj (Functor.congr_hom h.symm f) (objFiber' h x)] + simp [Grpd.forgetToCat, id_eq, Functor.comp_obj, Functor.comp_map, + Grpd.comp_eq_comp, objFiber', objFiber, + Grpd.eqToHom_obj, cast_cast, cast_eq] + · simp only [objFiber', Functor.comp_obj, objFiber, + Grpd.eqToHom_obj, cast_cast, cast_eq] + · simp only [heq_cast_iff_heq, heq_eq_eq] + · simp [Grpd.eqToHom_obj, Grpd.coe_of, objFiber', Functor.comp_obj, + objFiber, cast_cast, cast_eq] + +variable (α) (β) (B) in +def pair : Γ ⥤ PGrpd.{v₁,u₁} := + PGrpd.functorTo (sigma _ B) (pairObjFiber h) (pairMapFiber h) + (pairMapFiber_id h) (pairMapFiber_comp h) + +@[simp] theorem pair_obj_base (x : Γ) : + ((pair α β B h).obj x).base = ∫(ι (α ⋙ forgetToGrpd) x ⋙ B) := + rfl + +@[simp] theorem pair_obj_fiber (x : Γ) : + ((pair α β B h).obj x).fiber = pairObjFiber h x := + rfl + +@[simp] theorem pair_map_base {x y : Γ} (f : x ⟶ y) : + ((pair α β B h).map f).base = sigmaMap B f := + rfl + +@[simp] theorem pair_map_fiber {x y : Γ} (f : x ⟶ y) : + ((pair α β B h).map f).fiber = pairMapFiber h f := + rfl + +@[simp] theorem pair_comp_forgetToGrpd : + pair α β B h ⋙ forgetToGrpd = sigma (α ⋙ forgetToGrpd) B := rfl + +section + +variable {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) + +include h in +theorem pair_naturality_aux : (σ ⋙ β) ⋙ forgetToGrpd = + sec ((σ ⋙ α) ⋙ forgetToGrpd) (σ ⋙ α) rfl ⋙ pre (α ⋙ forgetToGrpd) σ ⋙ B := by + rw [Functor.assoc, h, ← Functor.assoc, sec_naturality] + rfl + +theorem pair_naturality_ι_pre (x) : + (ι ((σ ⋙ α) ⋙ forgetToGrpd) x ⋙ pre (α ⋙ forgetToGrpd) σ) + = ι (α ⋙ forgetToGrpd) (σ.obj x) := by + apply ι_comp_pre (α ⋙ forgetToGrpd) σ x + +theorem pair_naturality_obj (x : Δ) : HEq (pairObjFiber h (σ.obj x)) + (pairObjFiber (pair_naturality_aux h σ) x) := by + apply hext' + · rw [← Functor.assoc, pair_naturality_ι_pre] + · simp only [heq_eq_eq] + erw [pairObjFiber_base] + · simp only [heq_eq_eq] + erw [pairObjFiber_fiber] + +theorem pair_naturality_aux_1 {x y} (f : x ⟶ y) : + HEq ((sigmaMap B (σ.map f)).obj (pairObjFiber h (σ.obj x))) + ((sigmaMap (pre (α ⋙ forgetToGrpd) σ ⋙ B) f).obj (pairObjFiber (pair_naturality_aux h σ) x)) := by + apply hext' + . apply Eq.symm + calc ι (σ ⋙ α ⋙ forgetToGrpd) y ⋙ pre (α ⋙ forgetToGrpd) σ ⋙ B = + (ι ((σ ⋙ α) ⋙ forgetToGrpd) y ⋙ pre (α ⋙ forgetToGrpd) σ) ⋙ B := by exact + rfl + _ = ι (α ⋙ forgetToGrpd) (σ.obj y) ⋙ B := by rw! [pair_naturality_ι_pre] + . simp only [heq_eq_eq] + erw [sigmaMap_obj_base] + . simp only [heq_eq_eq] + erw [sigmaMap_obj_fiber] + +theorem pair_naturality : σ ⋙ pair α β B h = pair (σ ⋙ α) (σ ⋙ β) (pre (α ⋙ forgetToGrpd) σ ⋙ B) + (by erw [Functor.assoc, h, ← Functor.assoc, sec_naturality, Functor.assoc]) := by + apply PGrpd.Functor.hext + · apply sigma_naturality + · intro x + apply pair_naturality_obj + · intro x y f + apply Hom.hext' + · rw [← Functor.assoc, pair_naturality_ι_pre] + · apply pair_naturality_aux_1 + · apply pair_naturality_obj + · simp [- Functor.comp_obj, - Functor.comp_map, Functor.comp_map, mapFiber_naturality] + · simp [- Functor.comp_obj, - Functor.comp_map, Functor.comp_map, ← mapFiber'_naturality] + +end + +end + +namespace sigma +section +variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) + +@[simps] def fstAux : sigma A B ⟶ A where + app x := Grpd.homOf forget + +def fstAux' : ∫(sigma A B) ⥤ ∫(A) := + map (fstAux B) + +/-- `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 ⋙ forgetToGrpd = forget ⋙ A := by + dsimp only [fst, fstAux'] + rw [Functor.assoc, (Functor.Groupoidal.isPullback A).comm_sq, + ← Functor.assoc, map_forget] + +end + +section + +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} + (B : ∫(A) ⥤ Grpd.{v₁,u₁}) + +@[simp] def assocFib (x : Γ) : sigmaObj B x ⥤ ∫(B) := + pre _ _ + +def assocIso {x y : Γ} (f : x ⟶ y) : + assocFib B x ≅ sigmaMap B f ⋙ assocFib B y := + preNatIso B (ιNatIso A f) + +@[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] + +theorem assocIso_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : assocIso B (f ≫ g) = + assocIso B f ≪≫ Functor.isoWhiskerLeft (sigmaMap B f) (assocIso B g) + ≪≫ eqToIso (by simp [sigmaMap_comp, Functor.assoc]) := by + simp only [assocFib, sigmaMap, assocIso, preNatIso_congr B (ιNatIso_comp A f g), Iso.trans_hom, + Functor.isoWhiskerLeft_hom, eqToIso.hom, pre_comp, preNatIso_comp, preNatIso_eqToIso, + isoWhiskerLeft_eqToIso, eqToIso_trans, Functor.isoWhiskerLeft_trans, Iso.trans_assoc] + rfl + +def assocHom {x y : Γ} (f : x ⟶ y) : + assocFib B x ⟶ sigmaMap B f ⋙ assocFib B y := + (assocIso B f).hom + +@[simp] theorem assocHom_id {x : Γ} : + assocHom B (𝟙 x) = eqToHom (by simp [sigmaMap_id, Functor.id_comp]) := by + simp [assocHom, assocIso_id] + +theorem assocHom_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : + assocHom B (f ≫ g) = assocHom B f ≫ Functor.whiskerLeft (sigmaMap B f) (assocHom B g) ≫ + eqToHom (by simp [sigmaMap_comp, Functor.assoc]) := by + simp [assocHom, assocIso_comp] + +def assoc : ∫(sigma A B) ⥤ ∫(B) := + functorFrom (assocFib B) (assocHom B) (by simp) (by simp [assocHom_comp]) + +def snd : ∫(sigma A B) ⥤ PGrpd := + assoc B ⋙ toPGrpd B + +theorem ι_sigma_comp_map_fstAux (x) : ι (sigma A B) x ⋙ map (fstAux B) + = forget ⋙ ι A x := by + apply FunctorTo.hext + · rw [Functor.assoc, map_forget] + rfl + · intro x + simp + · intro x y f + simp only [sigma_obj, sigmaObj, Functor.comp_obj, ι_obj_base, + Functor.comp_map, ι_map_base, fstAux_app, ι_obj_fiber, + Functor.Groupoidal.forget_obj, map_map_fiber, sigma_map, eqToHom_refl, ι_map_fiber, + Functor.Groupoidal.forget_map, Category.id_comp, heq_eq_eq] + convert comp_base (eqToHom _) f + · rfl + · simp + +theorem functorFrom_comp_fib_assocFib_forget : + functorFrom_comp_fib (assocFib B) forget = asFunctorFrom_fib (map (fstAux B)) := by + ext x + exact (ι_sigma_comp_map_fstAux B x).symm + +lemma ιNatTrans_app_base_eq {c₁ c₂ : Γ} (f: c₁ ⟶ c₂) (x : ((sigma A B).obj c₁)) : + (ιNatTrans f).app (base x) = (map (fstAux B)).map ((ιNatTrans f).app x) := by + apply Hom.hext + · rfl + · simp only [map_map_fiber, eqToHom_refl, Category.id_comp] + rfl + +theorem assoc_forget : assoc B ⋙ forget = fstAux' B := by + simp only [assoc, fstAux', functorFrom_comp] + rw [← asFunctorFrom (map (fstAux B))] + fapply Functor.Grothendieck.functorFrom_eq_of -- FIXME: bleeding Grothendieck + · exact functorFrom_comp_fib_assocFib_forget B + · intro c₁ c₂ f + rw [comp_eqToHom_iff] + ext x + simp only [NatTrans.comp_app, eqToHom_app, eqToHom_refl, Category.comp_id, Category.id_comp] + apply ιNatTrans_app_base_eq + +theorem snd_forgetToGrpd : snd B ⋙ forgetToGrpd = fstAux' B ⋙ B := + calc + _ = assoc B ⋙ forget ⋙ B := rfl + _ = fstAux' B ⋙ B := by rw [← assoc_forget]; rfl + +@[simp] theorem fst_obj_fiber {x} : ((fst B).obj x).fiber = x.fiber.base := rfl + +@[simp] theorem fst_map_fiber {x y} (f : x ⟶ y) : ((fst B).map f).fiber = f.fiber.base := by + simp [fst, fstAux'] + +@[simp] theorem snd_obj_fiber {x} : ((snd B).obj x).fiber = x.fiber.fiber := by + simp [snd, assoc]; rfl + +@[simp] theorem assoc_hom_app_fiber {x y : ∫(sigma A B)} (f : x ⟶ y) : + (assocHom B (Hom.base f)).app x.fiber + = homMk (homMk f.base (𝟙 _)) (𝟙 _) := by + apply Hom.hext + · apply Hom.hext + · simp [sigmaObj, assocFib, Functor.comp_obj, assocHom, + assocIso, preNatIso_hom_app_base, ιNatIso_hom] + · rw [assocHom, assocIso, preNatIso_hom_app_base, ιNatIso_hom] + simp + rfl + · simp [assocHom, assocIso] + rfl + +-- FIXME: should probably make `snd_map_base` and use that to prove the `eqToHom` +@[simp] theorem snd_map_fiber {x y} (f : x ⟶ y) : ((snd B).map f).fiber = + eqToHom (by simp [snd, assoc]; rfl) ≫ Hom.fiber (Hom.fiber f) := by + simp only [snd, assoc, Functor.comp_map] + rw! [Functor.Groupoidal.functorFrom_map, assoc_hom_app_fiber] + simp only [toPGrpd_map_fiber, Functor.Groupoidal.comp_fiber] + rw! (transparency := .default) [CategoryTheory.Functor.map_id] + simp + +end + +section + +variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) + (αβ : Γ ⥤ PGrpd.{v₁,u₁}) (hαβ : αβ ⋙ forgetToGrpd = sigma A B) + +/-- Let `Γ` be a category. +For any pair of functors `A : Γ ⥤ Grpd` and `B : ∫(A) ⥤ Grpd`, +and any "term of sigma", meaning a functor `αβ : Γ ⥤ PGrpd` +satisfying `αβ ⋙ forgetToGrpd = sigma A B : Γ ⥤ Grpd`, +there is a "term of `A`" `fst' : Γ ⥤ PGrpd` such that `fst ⋙ forgetToGrpd = A`, +thought of as `fst' : A`. +There is a "type" `dependent' : ∫(fst ⋙ forgetToGrpd) ⥤ Grpd`, +which is hequal to `B` modulo `fst ⋙ forgetToGrpd` being equal to `A`. +And there is a "term" `snd' : Γ ⥤ PGrpd` satisfying +`snd' ⋙ forgetToGrpd = sec _ fst rfl ⋙ dependent'`. +-/ +def fst' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ fst B + +@[inherit_doc fst'] theorem fst'_forgetToGrpd : fst' B αβ hαβ ⋙ forgetToGrpd = A := + rfl + +@[inherit_doc fst'] def dependent' : ∫(fst' B αβ hαβ ⋙ forgetToGrpd) ⥤ Grpd := + map (eqToHom rfl) ⋙ B + +end + +section +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) + (αβ : Γ ⥤ PGrpd.{v₁,u₁}) (hαβ : αβ ⋙ forgetToGrpd = sigma A B) + +@[inherit_doc fst'] def snd' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ snd B + +@[simp] theorem fst'_obj_base {x} : ((fst' B αβ hαβ).obj x).base = + A.obj x := rfl + +theorem fst'_obj_fiber {x} : ((fst' B αβ hαβ).obj x).fiber = (objFiber' hαβ x).base := by + simp [fst'] + +@[simp] theorem fst'_map_base {x y} (f : x ⟶ y) : ((fst' B αβ hαβ).map f).base = + A.map f := rfl + +theorem fst'_map_fiber {x y} (f : x ⟶ y) : ((fst' B αβ hαβ).map f).fiber = + (mapFiber' hαβ f).base := by + simp [fst'] + +theorem sec_fstAux' : sec (sigma A B) αβ hαβ ⋙ fstAux' B = + sec (fst' B αβ hαβ ⋙ forgetToGrpd) (fst' B αβ hαβ) rfl := by + apply FunctorTo.hext + · rfl + · intro x + erw [sec_obj_fiber] + rfl + · intro x y f + erw [sec_map_fiber] + simp [fstAux', mapFiber'_rfl, mapFiber, fst'_map_fiber] + +@[inherit_doc fst] theorem snd'_forgetToGrpd : snd' B αβ hαβ ⋙ forgetToGrpd + = sec _ (fst' B αβ hαβ) rfl ⋙ dependent' B αβ hαβ := by + rw [snd', Functor.assoc, snd_forgetToGrpd, dependent', ← Functor.assoc, sec_fstAux'] + simp [map_id_eq, Functor.id_comp] + +theorem snd'_obj_fiber {x} : ((snd' B αβ hαβ).obj x).fiber = (objFiber' hαβ x).fiber := by + simp [snd'] + +-- FIXME: here the `simp` proof should also be factored through a `snd_map_base` +theorem snd'_map_fiber {x y} (f : x ⟶ y) : ((snd' B αβ hαβ).map f).fiber = + eqToHom (by simp [snd', snd, assoc]; rfl) ≫ Hom.fiber (mapFiber' hαβ f) := by + simp [snd'] + +theorem ι_fst'_forgetToGrpd_comp_dependent' (x) : + ι (fst' B αβ hαβ ⋙ forgetToGrpd) x ⋙ dependent' B αβ hαβ = ι A x ⋙ B := by + simp [dependent', map_id_eq, Functor.id_comp, fst'_forgetToGrpd] + +theorem pairObjFiber_snd'_eq (x : Γ) : pairObjFiber (snd'_forgetToGrpd B αβ hαβ) x = + objMk (objFiber' hαβ x).base (objFiber' (snd'_forgetToGrpd B αβ hαβ) x) := by + apply hext + · rw [pairObjFiber_base] + simp [objFiber, fst'_obj_fiber] + · rw [pairObjFiber_fiber] + simp + +theorem pairObjFiber_snd'_heq (x : Γ) : HEq (pairObjFiber (snd'_forgetToGrpd B αβ hαβ) x) + (αβ.obj x).fiber := by + rw [pairObjFiber_snd'_eq] + apply @HEq.trans _ _ _ _ ((objFiber'EqToHom hαβ x).obj (αβ.obj x).fiber) _ ?_ ?_ + · apply hext' + · apply ι_fst'_forgetToGrpd_comp_dependent' + · rfl + · rfl + · simp [Grpd.eqToHom_obj] + +theorem pairMapFiber_snd'_eq {x y} (f : x ⟶ y) : + pairMapFiber (snd'_forgetToGrpd B αβ hαβ) f + = homMk (mapFiber (fst' B αβ hαβ) f) + (eqToHom (pairMapFiber_aux (snd'_forgetToGrpd B αβ hαβ) f) + ≫ mapFiber' (snd'_forgetToGrpd B αβ hαβ) f) := by + apply Hom.hext + · simp + · simp + +theorem pairMapFiber_snd'_heq_src_heq {x y} (f : x ⟶ y) : + HEq ((sigmaMap (dependent' B αβ hαβ) f).obj (pairObjFiber (snd'_forgetToGrpd _ _ hαβ) x)) + ((objFiber'EqToHom hαβ y).obj ((αβ.map f).base.obj (αβ.obj x).fiber)) := by + have h : (αβ.map f).base.obj (αβ.obj x).fiber = _ := + Functor.congr_obj (Functor.congr_hom hαβ f) (αβ.obj x).fiber + rw [Grpd.eqToHom_obj, heq_cast_iff_heq, h] + simp only [Grpd.forgetToCat, dependent', eqToHom_refl, sigmaObj, Functor.comp_obj, + sigma_obj, sigma_map, Grpd.comp_eq_comp, + Grpd.eqToHom_obj, heq_cast_iff_heq] + rw! [map_id_eq] + congr + apply eq_of_heq + rw [heq_cast_iff_heq] + apply HEq.trans _ (pairObjFiber_snd'_heq B αβ hαβ x) + simp only [pairObjFiber, Functor.comp_obj, sigmaObj] + congr + simp [map_id_eq] + +theorem pairMapFiber_snd'_heq_trg_heq {y} : + HEq (pairObjFiber (snd'_forgetToGrpd B αβ hαβ) y) + ((objFiber'EqToHom hαβ y).obj (αβ.obj y).fiber) := by + rw [Grpd.eqToHom_obj, heq_cast_iff_heq] + exact pairObjFiber_snd'_heq B αβ hαβ y + +theorem sigmaMap_obj_objFiber' {x y} (f : x ⟶ y) : (sigmaMap B f).obj (objFiber' hαβ x) = + (objFiber'EqToHom hαβ y).obj ((αβ.map f).base.obj (αβ.obj x).fiber) := by + erw [Functor.congr_obj (Functor.congr_hom hαβ.symm f) (objFiber' hαβ x)] + simp [Grpd.eqToHom_obj, objFiber', objFiber] + +theorem pairMapFiber_snd'_heq {x y} (f : x ⟶ y) : HEq (pairMapFiber (snd'_forgetToGrpd B αβ hαβ) f) + (αβ.map f).fiber := by + rw [pairMapFiber_snd'_eq] + apply @HEq.trans _ _ _ _ ((objFiber'EqToHom hαβ y).map (αβ.map f).fiber) _ ?_ ?_ + · apply Hom.hext' + · apply ι_fst'_forgetToGrpd_comp_dependent' + · apply pairMapFiber_snd'_heq_src_heq + · rw [Grpd.eqToHom_obj, heq_cast_iff_heq] + exact pairObjFiber_snd'_heq B αβ hαβ y + · rw [homMk_base, mapFiber, fst'_map_fiber] + congr! + · apply sigmaMap_obj_objFiber' + · apply HEq.trans (eqToHom_comp_heq _ _) + simp + · simp only [homMk_fiber, eqToHom_comp_heq_iff] + apply HEq.trans (mapFiber'_heq _ f) + simp only [snd'_map_fiber, Functor.comp_map, eqToHom_comp_heq_iff] + congr! + · apply sigmaMap_obj_objFiber' + · apply HEq.trans (eqToHom_comp_heq _ _) + simp + · simp [Grpd.eqToHom_hom] + +theorem eta : pair (fst' B αβ hαβ) (snd' B αβ hαβ) + (dependent' B αβ hαβ) (snd'_forgetToGrpd _ _ _) = αβ := by + apply PGrpd.Functor.hext + · rw [pair, PGrpd.functorTo_forget, hαβ] + congr + simp [dependent', map_id_eq, Functor.id_comp] + · intro x + exact pairObjFiber_snd'_heq _ _ _ _ + · intro x y f + exact pairMapFiber_snd'_heq _ _ _ _ + +end + +section +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {α β : Γ ⥤ PGrpd.{v₁,u₁}} + {B : ∫(α ⋙ forgetToGrpd) ⥤ Grpd.{v₁,u₁}} (h : β ⋙ forgetToGrpd = sec _ α rfl ⋙ B) + +@[simp] theorem fst'_pair : fst' B (pair α β B h) (pair_comp_forgetToGrpd _) = α := by + apply PGrpd.Functor.hext + · rw [fst'_forgetToGrpd] + · intro x + erw [fst'_obj_fiber] + · intro x y f + simp only [fst'_map_fiber, objFiber'_rfl, mapFiber'_rfl] + erw [pairMapFiber_base, mapFiber] + +@[simp] theorem snd'_pair : snd' B (pair α β B h) (pair_comp_forgetToGrpd _) = β := by + apply PGrpd.Functor.hext + · rw [snd'_forgetToGrpd, h, dependent'] + congr 2 + · rw [fst'_pair] + · simp [map_id_eq, Functor.id_comp] + · intro x + simp only [snd'_obj_fiber, objFiber'_rfl, objFiber, pair_obj_fiber, pairObjFiber_fiber] + simp [objFiber', Grpd.eqToHom_obj, objFiber] + · intro x y f + simp only [snd'_map_fiber] + apply (eqToHom_comp_heq _ _).trans + simp only [sigmaObj, objFiber'_rfl, sigma_obj, Grpd.coe_of, mapFiber', eqToHom_refl, + Grpd.id_eq_id, mapFiber'EqToHom, pair_map_fiber, Functor.id_map, + Functor.Groupoidal.comp_fiber, Functor.Groupoidal.id_fiber, eqToHom_map] + apply (eqToHom_comp_heq _ _).trans + rw [pairMapFiber_fiber] + apply (eqToHom_comp_heq _ _).trans + simp only [mapFiber', mapFiber'EqToHom, Grpd.eqToHom_hom, eqToHom_trans_assoc] + apply (eqToHom_comp_heq _ _).trans + simp + +end + +end sigma + +end FunctorOperation + +open FunctorOperation + +/-- +Behavior of the Σ-type former (a natural transformation) on an input. +By Yoneda, "an input" is the same as a map from a representable into the domain. +-/ +def USig.Sig_app {Γ : Ctx} + (AB : Γ ⟶ U.{v}.Ptp.obj U.{v}.Ty) : + Γ ⟶ U.{v}.Ty := + toCoreAsSmallEquiv.symm (sigma _ (U.PtpEquiv.snd AB)) + +/-- +Naturality for the formation rule for Σ-types. +Also known as Beck-Chevalley +-/ +theorem USig.Sig_naturality {Γ Δ : Ctx} (σ : Δ ⟶ Γ) + (AB : Γ ⟶ U.{v}.Ptp.obj U.{v}.Ty) : + USig.Sig_app ((σ) ≫ AB) = (σ) ≫ USig.Sig_app AB := by + dsimp only [USig.Sig_app] + slice_rhs 1 2 => rw [Grpd.comp_eq_comp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left] + rw [sigma_naturality] + -- note the order of rewrite is first the fiber, then the base + -- this allows rw! to cast the proof in the `eqToHom` + conv => left; rw! [U.PtpEquiv.fst_comp_left] + rw [U.PtpEquiv.snd_comp_left] + congr 1 + simp [map_id_eq, Functor.id_comp] + +/-- The formation rule for Σ-types for the ambient natural model `base` + If possible, don't use NatTrans.app on this, + instead precompose it with maps from representables. +-/ +def USig.Sig : U.{v}.Ptp.obj U.{v}.Ty ⟶ U.{v}.Ty := + ofYoneda USig.Sig_app USig.Sig_naturality + +lemma USig.Sig_app_eq {Γ : Ctx} (AB : Γ ⟶ _) : AB ≫ USig.Sig = + USig.Sig_app AB := by + simp [USig.Sig] + +open U.compDom + +def USig.pair_app {Γ : Ctx} (ab : Γ ⟶ U.{v}.uvPolyTp.compDom U.{v}.uvPolyTp) : + Γ ⟶ U.{v}.Tm := + toCoreAsSmallEquiv.symm (pair _ _ _ (snd_forgetToGrpd ab)) + +theorem USig.pair_naturality {Γ Δ : Ctx} (f : Δ ⟶ Γ) + (ab : Γ ⟶ U.compDom.{v}) : + USig.pair_app ((f) ≫ ab) = (f) ≫ USig.pair_app ab := by + dsimp only [USig.pair_app] + slice_rhs 1 2 => rw [Grpd.comp_eq_comp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left] + rw [FunctorOperation.pair_naturality] + -- Like with `USig.Sig_naturality` rw from inside to outside (w.r.t type dependency) + rw! (castMode := .all) [dependent_comp, snd_comp, fst_comp] + simp [map_id_eq, Functor.id_comp] + +def USig.pair : U.compDom.{v} ⟶ U.{v}.Tm := + ofYoneda USig.pair_app USig.pair_naturality + +lemma USig.pair_comp_left {Γ : Ctx} (ab : Γ ⟶ _) : ab ≫ USig.pair = + USig.pair_app ab := by + simp [USig.pair] + +theorem USig.pair_tp {Γ : Ctx} (ab : Γ ⟶ _) : pair_app ab ≫ U.tp = Sig_app (ab ≫ U.compP) := by + simp [pair_app, Sig_app] + erw [← toCoreAsSmallEquiv_symm_apply_comp_right, pair_comp_forgetToGrpd] + rw! (castMode := .all) [fst_forgetToGrpd, Grpd.comp_eq_comp] + rfl + +namespace SigPullback + +open Limits + +section + +section +variable {Γ : Ctx} (AB : Γ ⟶ U.Ptp.obj.{v} U.Ty.{v}) + (αβ : Γ ⟶ U.Tm.{v}) (hαβ : αβ ≫ U.tp = USig.Sig_app AB) + +include hαβ in +theorem toCoreAsSmallEquiv_forgetToGrpd : toCoreAsSmallEquiv αβ ⋙ forgetToGrpd + = sigma (U.PtpEquiv.fst AB) (U.PtpEquiv.snd AB) := by + erw [← toCoreAsSmallEquiv_apply_comp_right, + ← Grpd.comp_eq_comp, hαβ] + rw [USig.Sig_app, toCoreAsSmallEquiv.apply_symm_apply] + +def lift : Γ ⟶ U.compDom.{v} := + let β' := U.PtpEquiv.snd AB + let αβ' := toCoreAsSmallEquiv αβ + let hαβ' : toCoreAsSmallEquiv αβ ⋙ forgetToGrpd + = sigma (U.PtpEquiv.fst AB) (U.PtpEquiv.snd AB) := + toCoreAsSmallEquiv_forgetToGrpd _ _ hαβ + U.compDom.mk (sigma.fst' β' αβ' hαβ') _ rfl (sigma.dependent' β' αβ' hαβ') + (sigma.snd' β' αβ' hαβ') (sigma.snd'_forgetToGrpd β' αβ' hαβ') + +lemma fst_lift : fst (lift AB αβ hαβ) = + sigma.fst' (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) + (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by + simp [lift, fst_mk] + +lemma snd_lift : snd (lift AB αβ hαβ) = sigma.snd' + (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) + (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by + simp [lift, snd_mk] + +lemma dependent_lift : dependent (lift AB αβ hαβ) = + map (eqToHom (by rw [fst_lift AB αβ hαβ])) ⋙ sigma.dependent' + (U.PtpEquiv.snd AB (U.PtpEquiv.fst AB) _) (toCoreAsSmallEquiv αβ) + (toCoreAsSmallEquiv_forgetToGrpd AB αβ hαβ) := by + simp [lift, dependent_mk] + +theorem pair_app_lift : USig.pair_app (SigPullback.lift AB αβ hαβ) = αβ := by + rw [USig.pair_app, toCoreAsSmallEquiv.symm_apply_eq] + rw! [dependent_lift, snd_lift, fst_lift] + simp [eqToHom_refl, map_id_eq, sigma.eta] + +theorem lift_compP : lift.{v} AB αβ hαβ ≫ U.compP.{v} = AB := by + apply U.PtpEquiv.hext + · rw [← fst_forgetToGrpd] + dsimp only [lift] + rw [fst_mk, sigma.fst'_forgetToGrpd] + · apply HEq.trans (dependent_heq _).symm + rw [lift, dependent_mk] + dsimp [sigma.dependent'] + simp [map_id_eq, Functor.id_comp] + apply map_eqToHom_comp_heq + +theorem hom_ext (m n : Γ ⟶ U.compDom) + (hComp : m ≫ U.compP.{v} = n ≫ U.compP) + (hPair : m ≫ USig.pair = n ≫ USig.pair) : + m = n := by + have h : (pair (fst m) (snd m) (dependent m) + (snd_forgetToGrpd m)) = + (pair (fst n) (snd n) (dependent n) + (snd_forgetToGrpd n)) := + calc _ + _ = toCoreAsSmallEquiv (m ≫ USig.pair) := by + simp [USig.pair_comp_left m, USig.pair_app] + _ = toCoreAsSmallEquiv (n ≫ USig.pair) := by rw [hPair] + _ = _ := by + simp [USig.pair_comp_left n, USig.pair_app] + have : fst m ⋙ forgetToGrpd = fst n ⋙ forgetToGrpd := by + rw [fst_forgetToGrpd, fst_forgetToGrpd, hComp] + have hdep : HEq (dependent m) (dependent n) := by + refine (dependent_heq _).trans + $ HEq.trans ?_ $ (dependent_heq _).symm + rw [hComp] + fapply U.compDom.hext + · calc fst m + _ = sigma.fst' _ (FunctorOperation.pair (fst m) (snd m) + (dependent m) (snd_forgetToGrpd m)) _ := + (sigma.fst'_pair _).symm + _ = sigma.fst' _ (FunctorOperation.pair (fst n) (snd n) + (dependent n) (snd_forgetToGrpd n)) _ := by + rw! [h] + congr! 1 + _ = fst n := sigma.fst'_pair _ + · exact hdep + · calc snd m + _ = sigma.snd' _ (FunctorOperation.pair (fst m) (snd m) + (dependent m) (snd_forgetToGrpd m)) _ := + (sigma.snd'_pair _).symm + _ = sigma.snd' _ (FunctorOperation.pair (fst n) (snd n) + (dependent n) (snd_forgetToGrpd n)) _ := by + rw! [h] + congr! + _ = snd n := sigma.snd'_pair _ + +theorem uniq (m : Γ ⟶ U.compDom) + (hl : USig.pair_app m = αβ) + (hr : m ≫ U.compP = AB) : + m = lift AB αβ hαβ := by + apply hom_ext + · rw [hr, lift_compP] + · rw [USig.pair_comp_left, hl, USig.pair_comp_left, pair_app_lift] + +end +end + +end SigPullback + +theorem USig.isPullback : IsPullback USig.pair U.compP.{v,u} U.tp.{v,u} USig.Sig := + ofYoneda_isPullback _ _ _ _ _ _ (fun ab => USig.pair_tp ab) + (fun αβ AB hαβ => SigPullback.lift AB αβ hαβ) + (fun αβ AB hαβ => SigPullback.pair_app_lift AB αβ hαβ) + (fun αβ AB hαβ => SigPullback.lift_compP.{v,u} AB αβ hαβ) + (fun αβ AB hαβ m hl hr => SigPullback.uniq.{v,u} AB αβ hαβ m hl hr) + +def USig : Universe.Sigma U.{v} where + Sig := USig.Sig + pair := USig.pair + Sig_pullback := USig.isPullback + +def liftSeqSigs' (i : ℕ) (ilen : i < 4) : + Universe.Sigma (liftSeqObjs i ilen) := + match i with + | 0 => USig.{0, 4} + | 1 => USig.{1, 4} + | 2 => USig.{2, 4} + | 3 => USig.{3, 4} + | (n+4) => by omega + +instance liftSeqSigma : liftSeq.SigSeq where + nmSig := liftSeqSigs' + +end GroupoidModel +end diff --git a/HoTTLean/Groupoids/StructuredModel.lean b/HoTTLean/Groupoids/StructuredModel.lean new file mode 100644 index 00000000..c355fd56 --- /dev/null +++ b/HoTTLean/Groupoids/StructuredModel.lean @@ -0,0 +1,358 @@ +import HoTTLean.Groupoids.Sigma + +/-! +Here we construct universes for the groupoid natural model. +-/ + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section +open CategoryTheory Limits UnstructuredModel StructuredModel Universe + Functor.Groupoidal GroupoidModel.Ctx GroupoidModel.U + +namespace GroupoidModel + +open U + +/-- The universe the classifies `v`-large terms and types. + The π-clan we use is the set of groupoid isofibrations. +-/ +@[simps!] +def StructuredU : Universe Grpd.IsIsofibration where + __ := U + morphismProperty := sorry + +namespace U + +open MonoidalCategory + +def liftSeqObjs (i : Nat) (h : i < 4) : Universe Grpd.IsIsofibration.{5} := + match i with + | 0 => StructuredU.{0,4} + | 1 => StructuredU.{1,4} + | 2 => StructuredU.{2,4} + | 3 => StructuredU.{3,4} + | (n+4) => by omega + +def lift : UHom StructuredU.{v, max u (v+2)} StructuredU.{v+1, max u (v+2)} := + sorry + -- @UHom.ofTyIsoExt _ _ _ _ _ _ + -- { mapTy := U.liftTy.{v,max u (v+2)} + -- mapTm := U.liftTm + -- pb := IsPullback.liftTm_isPullback } + -- asSmallClosedType + -- isoExtAsSmallClosedType.{v,u} + +def liftSeqHomSucc' (i : Nat) (h : i < 3) : + UHom (liftSeqObjs i (by omega)) (liftSeqObjs (i + 1) (by omega)) := + match i with + | 0 => lift.{0,4} + | 1 => lift.{1,4} + | 2 => lift.{2,4} + | (n+3) => by omega + +/-- + The groupoid natural model with three nested representable universes + within the ambient natural model. +-/ +def liftSeq : UHomSeq Grpd.IsIsofibration.{5} where + length := 3 + objs := liftSeqObjs + homSucc' := liftSeqHomSucc' + +def USig : Universe.Sigma StructuredU := + PolymorphicSigma.ofUnstructured GroupoidModel.USig + +#exit +def liftSeqSigs' (i : ℕ) (ilen : i < 4) : + Universe.Sigma (liftSeqObjs i ilen) := + match i with + | 0 => USig.{0, 4} + | 1 => USig.{1, 4} + | 2 => USig.{2, 4} + | 3 => USig.{3, 4} + | (n+4) => by omega + +instance liftSeqSigma : liftSeq.SigSeq where + nmSig := liftSeqSigs' + + +-- section + +-- variable {Γ : Grpd} {C : Type (v+1)} [Category.{v} C] {Δ : Grpd} (σ : Δ ⟶ Γ) + +-- namespace PtpEquiv + +-- variable (AB : Γ ⟶ StructuredU.{v}.Ptp.obj (Ctx.coreAsSmall C)) + +-- /-- +-- A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` +-- is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, +-- thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. +-- `PtpEquiv.fst` is the `A` in this pair. +-- -/ +-- def fst : Γ ⥤ Grpd.{v,v} := +-- toCoreAsSmallEquiv (Universe.PtpEquiv.fst U AB) + +-- variable (A := fst AB) (hA : A = fst AB := by rfl) + +-- /-- +-- A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` +-- is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, +-- thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. +-- `PtpEquiv.snd` is the `B` in this pair. +-- -/ +-- def snd : ∫A ⥤ C := +-- toCoreAsSmallEquiv (Universe.PtpEquiv.snd U AB (toCoreAsSmallEquiv.symm A) (by +-- simp [Universe.PtpEquiv.fst, hA, fst])) + +-- nonrec theorem fst_comp_left : fst (σ ≫ AB) = σ ⋙ fst AB := by +-- dsimp only [fst] +-- rw [PtpEquiv.fst_comp_left, ← toCoreAsSmallEquiv_apply_comp_left, Grpd.comp_eq_comp] + +-- theorem fst_comp_right {D : Type (v + 1)} [Category.{v, v + 1} D] (F : C ⥤ D) : +-- fst (AB ≫ U.Ptp.map (Ctx.coreAsSmallFunctor F)) = fst AB := by +-- dsimp only [fst] +-- rw [Universe.PtpEquiv.fst_comp_right] + +-- nonrec theorem snd_comp_left : snd (σ ≫ AB) (σ ⋙ A) (by rw [hA, fst_comp_left]) = +-- map (eqToHom (by rw [hA])) ⋙ pre _ σ ⋙ snd AB := by +-- dsimp only [snd] +-- erw [PtpEquiv.snd_comp_left _ rfl +-- (by simp [toCoreAsSmallEquiv_symm_apply_comp_left, Grpd.comp_eq_comp, hA, fst]), +-- toCoreAsSmallEquiv_apply_comp_left] +-- subst hA +-- simp [map_id_eq, substWk_eq]; rfl + +-- /-- +-- A map `(AB : (Γ) ⟶ U.{v}.Ptp.obj (Ctx.ofCategory C))` +-- is equivalent to a pair of functors `A : Γ ⥤ Grpd` and `B : ∫(fst AB) ⥤ C`, +-- thought of as a dependent pair `A : Type` and `B : A ⟶ Type` when `C = Grpd`. +-- `PtpEquiv.mk` constructs such a map `AB` from such a pair `A` and `B`. +-- -/ +-- def mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : +-- Γ ⟶ U.{v}.Ptp.obj (Ctx.coreAsSmall C) := +-- Universe.PtpEquiv.mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B) + +-- theorem hext (AB1 AB2 : Γ ⟶ U.{v}.Ptp.obj Ty.{v}) (hfst : fst AB1 = fst AB2) +-- (hsnd : HEq (snd AB1) (snd AB2)) : AB1 = AB2 := by +-- have hfst' : Universe.PtpEquiv.fst U AB1 = Universe.PtpEquiv.fst U AB2 := by +-- dsimp [fst] at hfst +-- aesop +-- apply Universe.PtpEquiv.ext U (Universe.PtpEquiv.fst U AB1) ?_ hfst' ?_ +-- · simp +-- · dsimp only [snd] at hsnd +-- apply toCoreAsSmallEquiv.injective +-- conv => right; rw! (castMode := .all) [hfst'] +-- simp [← heq_eq_eq] +-- exact hsnd + +-- @[simp] +-- lemma fst_mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : +-- fst (mk A B) = A := by +-- simp [fst, mk, Universe.PtpEquiv.fst_mk] + +-- lemma Grpd.eqToHom_comp_heq {A B : Grpd} {C : Type*} [Category C] +-- (h : A = B) (F : B ⥤ C) : eqToHom h ⋙ F ≍ F := by +-- subst h +-- simp [Grpd.id_eq_id, Functor.id_comp] + +-- lemma snd_mk (A A' : Γ ⥤ Grpd.{v,v}) (hA : A = A') (B : ∫(A) ⥤ C) : +-- snd (mk A B) A' (by rw [fst_mk, hA]) = map (eqToHom hA.symm) ⋙ B := by +-- dsimp only [snd, mk] +-- subst hA +-- rw [Universe.PtpEquiv.snd_mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B)] +-- erw [Equiv.apply_symm_apply toCoreAsSmallEquiv B] +-- simp [map_id_eq] + +-- lemma snd_mk_heq (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : +-- snd (mk A B) ≍ B := by +-- simp [snd_mk, map_eqToHom_comp_heq] + +-- end PtpEquiv + +-- def compDom := U.{v}.uvPolyTp.compDom U.{v}.uvPolyTp + +-- @[simp] +-- abbrev compP : compDom.{v} ⟶ U.{v}.Ptp.obj Ty.{v} := +-- Universe.compP U U + +-- namespace compDom + +-- variable (ab : (Γ) ⟶ compDom.{v}) + +-- /-- Universal property of `compDom`, decomposition (part 1). + +-- A map `ab : (Γ) ⟶ compDom` is equivalently three functors +-- `fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `fst : Γ ⥤ PGrpd` +-- is `(a : A)` in `(a : A) × (b : B a)`. +-- -/ +-- def fst : Γ ⥤ PGrpd.{v,v} := +-- toCoreAsSmallEquiv (Universe.compDomEquiv.fst ab) + +-- /-- Universal property of `compDom`, decomposition (part 2). + +-- A map `ab : (Γ) ⟶ compDom` is equivalently three functors +-- `fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `dependent : Γ ⥤ Grpd` +-- is `B : A → Type` in `(a : A) × (b : B a)`. +-- -/ +-- def dependent (A := fst ab ⋙ PGrpd.forgetToGrpd) (eq : fst ab ⋙ PGrpd.forgetToGrpd = A := by rfl) : +-- ∫(A) ⥤ Grpd.{v,v} := +-- toCoreAsSmallEquiv (Universe.compDomEquiv.dependent ab (toCoreAsSmallEquiv.symm A) (by +-- simp only [U_Ty, U_Tm, compDomEquiv.fst, U_tp, ← eq] +-- erw [toCoreAsSmallEquiv_symm_apply_comp_right] +-- simp [fst]; rfl)) + +-- /-- Universal property of `compDom`, decomposition (part 3). + +-- A map `ab : (Γ) ⟶ compDom` is equivalently three functors +-- `fst, dependent, snd` such that `snd_forgetToGrpd`. The functor `snd : Γ ⥤ PGrpd` +-- is `(b : B a)` in `(a : A) × (b : B a)`. +-- -/ +-- def snd : Γ ⥤ PGrpd.{v,v} := +-- toCoreAsSmallEquiv (Universe.compDomEquiv.snd ab) + +-- /-- Universal property of `compDom`, decomposition (part 4). + +-- A map `ab : (Γ) ⟶ compDom` is equivalently three functors +-- `fst, dependent, snd` such that `snd_forgetToGrpd`. +-- The equation `snd_forgetToGrpd` 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_forgetToGrpd : snd ab ⋙ PGrpd.forgetToGrpd = sec _ (fst ab) rfl ⋙ (dependent ab) := by +-- erw [← toCoreAsSmallEquiv_apply_comp_right, ← Grpd.comp_eq_comp, +-- Universe.compDomEquiv.snd_tp ab, sec_eq] +-- rfl + +-- /-- Universal property of `compDom`, constructing a map into `compDom`. -/ +-- def mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) +-- (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) +-- (B : ∫(A) ⥤ Grpd.{v,v}) +-- (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : +-- Γ ⟶ compDom.{v} := +-- Universe.compDomEquiv.mk (toCoreAsSmallEquiv.symm α) (A := toCoreAsSmallEquiv.symm A) +-- (by rw [← hA, toCoreAsSmallEquiv_symm_apply_comp_right]; rfl) +-- (toCoreAsSmallEquiv.symm B) (toCoreAsSmallEquiv.symm β) +-- (by +-- dsimp [U_tp, tp, Grpd.comp_eq_comp] +-- rw [← toCoreAsSmallEquiv_symm_apply_comp_right β PGrpd.forgetToGrpd, h, +-- toCoreAsSmallEquiv_symm_apply_comp_left] +-- congr 1 +-- simp only [sec_eq, Equiv.apply_symm_apply] +-- rw! (castMode := .all) [toCoreAsSmallEquiv.apply_symm_apply] +-- ) + +-- theorem fst_forgetToGrpd : fst ab ⋙ PGrpd.forgetToGrpd = +-- U.PtpEquiv.fst (ab ≫ compP.{v}) := by +-- erw [U.PtpEquiv.fst, ← compDomEquiv.fst_tp ab, ← toCoreAsSmallEquiv_apply_comp_right] +-- rfl + +-- theorem dependent_eq (A := fst ab ⋙ PGrpd.forgetToGrpd) +-- (eq : fst ab ⋙ PGrpd.forgetToGrpd = A := by rfl) : dependent ab A eq = +-- map (eqToHom (by rw [← eq, fst_forgetToGrpd])) ⋙ U.PtpEquiv.snd (ab ≫ compP.{v}) := by +-- dsimp only [dependent, PtpEquiv.snd] +-- rw [Universe.compDomEquiv.dependent_eq _ _ _, ← toCoreAsSmallEquiv_apply_comp_left] +-- subst eq +-- rw! [← fst_forgetToGrpd] +-- simp [map_id_eq] + +-- theorem dependent_heq : HEq (dependent ab) (U.PtpEquiv.snd (ab ≫ compP.{v})) := by +-- rw [dependent_eq] +-- apply Functor.precomp_heq_of_heq_id +-- · rw [fst_forgetToGrpd] +-- · rw [fst_forgetToGrpd] +-- · apply map_eqToHom_heq_id_cod + +-- theorem fst_comp : fst (σ ≫ ab) = σ ⋙ fst ab := by +-- dsimp only [fst] +-- rw [Universe.compDomEquiv.fst_comp, Grpd.comp_eq_comp, +-- toCoreAsSmallEquiv_apply_comp_left] + +-- theorem dependent_comp : dependent (σ ≫ ab) = +-- map (eqToHom (by rw [fst_comp, Functor.assoc])) +-- ⋙ pre _ σ ⋙ dependent ab := by +-- rw [dependent, dependent, +-- ← Universe.compDomEquiv.comp_dependent (eq1 := rfl) +-- (eq2 := by erw [← compDomEquiv.fst_comp_assoc, fst, toCoreAsSmallEquiv.eq_symm_apply]; rfl), +-- substWk_eq] +-- rfl + +-- theorem snd_comp : snd (σ ≫ ab) = σ ⋙ snd ab := by +-- dsimp only [snd] +-- rw [Universe.compDomEquiv.snd_comp, Grpd.comp_eq_comp, +-- toCoreAsSmallEquiv_apply_comp_left] + +-- /-- First component of the computation rule for `mk`. -/ +-- theorem fst_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) +-- (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) +-- (B : ∫(A) ⥤ Grpd.{v,v}) +-- (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : +-- fst (mk α A hA B β h) = α := by +-- simp [fst, mk, Universe.compDomEquiv.fst_mk] + +-- /-- Second component of the computation rule for `mk`. -/ +-- theorem dependent_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) +-- (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) +-- (B : ∫(A) ⥤ Grpd.{v,v}) +-- (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : +-- dependent (mk α A hA B β h) = map (eqToHom (by subst hA; rw [fst_mk])) ⋙ B := by +-- dsimp [dependent, mk] +-- rw [Equiv.apply_eq_iff_eq_symm_apply] +-- rw [compDomEquiv.dependent_mk] +-- · rw [toCoreAsSmallEquiv_symm_apply_comp_left] +-- erw [eqToHom_eq_homOf_map] +-- rfl +-- · simp [fst, compDomEquiv.fst_mk, hA] + +-- /-- Second component of the computation rule for `mk`. -/ +-- theorem snd_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) +-- (hA : α ⋙ PGrpd.forgetToGrpd = A := by rfl) +-- (B : ∫(A) ⥤ Grpd.{v,v}) +-- (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : +-- snd (mk α A hA B β h) = β := by +-- dsimp [snd, mk] +-- rw [Universe.compDomEquiv.snd_mk] +-- simp + +-- theorem ext (ab1 ab2 : Γ ⟶ U.compDom.{v}) +-- (hfst : fst ab1 = fst ab2) +-- (hdependent : dependent ab1 = map (eqToHom (by rw [hfst])) ⋙ dependent ab2) +-- (hsnd : snd ab1 = snd ab2) : ab1 = ab2 := by +-- dsimp only [compDom] at ab1 +-- have h1 : compDomEquiv.fst ab1 = compDomEquiv.fst ab2 := by +-- apply toCoreAsSmallEquiv.injective +-- assumption +-- fapply compDomEquiv.ext rfl h1 +-- · dsimp [dependent, fst] at hdependent +-- apply toCoreAsSmallEquiv.injective +-- convert hdependent +-- · rw [toCoreAsSmallEquiv_symm_apply_comp_right] +-- simp; rfl +-- rw! (castMode := .all) [toCoreAsSmallEquiv_symm_apply_comp_right, +-- Equiv.symm_apply_apply, h1, hfst] +-- simp [map_id_eq] +-- congr 1 +-- simp [← heq_eq_eq] +-- rfl +-- · apply toCoreAsSmallEquiv.injective +-- assumption + +-- theorem hext (ab1 ab2 : Γ ⟶ U.compDom.{v}) +-- (hfst : fst ab1 = fst ab2) (hdependent : HEq (dependent ab1) (dependent ab2)) +-- (hsnd : snd ab1 = snd ab2) : ab1 = ab2 := by +-- apply ext +-- · rw! [hdependent] +-- simp [← heq_eq_eq] +-- conv => right; rw! (castMode := .all) [hfst] +-- simp [map_id_eq] +-- · assumption +-- · assumption + +-- end compDom + +-- end + +end U +end GroupoidModel + +end diff --git a/HoTTLean/Groupoids/UHom.lean b/HoTTLean/Groupoids/UHom.lean new file mode 100644 index 00000000..8276e702 --- /dev/null +++ b/HoTTLean/Groupoids/UHom.lean @@ -0,0 +1,33 @@ +def liftSeqObjs (i : Nat) (h : i < 4) : Universe Grpd.IsIsofibration.{4} := + match i with + | 0 => U.{0,4} + | 1 => U.{1,4} + | 2 => U.{2,4} + | 3 => U.{3,4} + | (n+4) => by omega + +-- TODO: rename UHom to Universe.Lift +def lift : UHom U.{v, max u (v+2)} U.{v+1, max u (v+2)} := + @UHom.ofTyIsoExt _ _ _ _ _ _ + { mapTy := U.liftTy.{v,max u (v+2)} + mapTm := U.liftTm + pb := IsPullback.liftTm_isPullback } + asSmallClosedType + isoExtAsSmallClosedType.{v,u} + +def liftSeqHomSucc' (i : Nat) (h : i < 3) : + UHom (liftSeqObjs i (by omega)) (liftSeqObjs (i + 1) (by omega)) := + match i with + | 0 => lift.{0,4} + | 1 => lift.{1,4} + | 2 => lift.{2,4} + | (n+3) => by omega + +/-- + The groupoid natural model with three nested representable universes + within the ambient natural model. +-/ +def liftSeq : UHomSeq Grpd.IsIsofibration.{4} where + length := 3 + objs := liftSeqObjs + homSucc' := liftSeqHomSucc' diff --git a/HoTTLean/Groupoids/UnstructuredModel.lean b/HoTTLean/Groupoids/UnstructuredModel.lean new file mode 100644 index 00000000..aad9b213 --- /dev/null +++ b/HoTTLean/Groupoids/UnstructuredModel.lean @@ -0,0 +1,128 @@ +import Mathlib.CategoryTheory.Limits.Preserves.FunctorCategory +import Mathlib.CategoryTheory.Category.Cat.Limit + +import HoTTLean.Model.UHom +import HoTTLean.Grothendieck.Groupoidal.IsPullback +import HoTTLean.Groupoids.IsPullback +import HoTTLean.ForMathlib.CategoryTheory.IsIsofibration + +/-! +Here we construct universes for the groupoid natural model. +-/ + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section +open CategoryTheory Limits UnstructuredModel Universe + Functor.Groupoidal GroupoidModel.Ctx GroupoidModel.U + +namespace GroupoidModel + +open U + +/-- The universe the classifies `v`-large terms and types. + The π-clan we use is the set of groupoid isofibrations. +-/ +@[simps] +def U : Universe Grpd where + Ty := Ty.{v} + Tm := Tm.{v} + tp := tp + ext A := ext A + disp A := disp A + var A := var A + disp_pullback A := GroupoidModel.IsPullback.disp_pullback A + +namespace U + +open MonoidalCategory + +def asSmallClosedType : (tensorUnit _ : Ctx) ⟶ Ty.{v+1, max u (v+2)} := + toCoreAsSmallEquiv.symm ((Functor.const _).obj + (Grpd.of (Core (AsSmall.{v+1} Grpd.{v,v})))) + +def isoExtAsSmallClosedTypeHom : + Core (AsSmall.{max u (v+2)} Grpd.{v,v}) + ⥤ ∫(toCoreAsSmallEquiv (asSmallClosedType.{v, max u (v + 2)})) where + obj X := objMk ⟨⟨⟩⟩ ⟨AsSmall.up.obj.{_,_,v+1} (AsSmall.down.obj X.of)⟩ + map {X Y} F := homMk (𝟙 _) ⟨{ + hom := AsSmall.up.map.{_,_,v+1} (AsSmall.down.map F.iso.hom) + inv := AsSmall.up.map.{_,_,v+1} (AsSmall.down.map (F.iso.inv)) + hom_inv_id := by + simp only [← Functor.map_comp, Iso.hom_inv_id] + rfl + inv_hom_id := by + simp only [← Functor.map_comp, Iso.inv_hom_id] + rfl }⟩ + +def isoExtAsSmallClosedTypeInv : + ∫(toCoreAsSmallEquiv (asSmallClosedType.{v, max u (v + 2)})) ⥤ + Core (AsSmall.{max u (v+2)} Grpd.{v,v}) where + obj X := ⟨AsSmall.up.obj (AsSmall.down.obj.{_,_,v+1} X.fiber.of)⟩ + map {X Y} F := ⟨{ + hom := AsSmall.up.map.{_,_,max u (v+2)} + (AsSmall.down.map F.fiber.iso.hom) + inv := AsSmall.up.map.{_,_,max u (v+2)} + (AsSmall.down.map F.fiber.iso.inv) + hom_inv_id := by + simp only [← Functor.map_comp, Iso.hom_inv_id] + rfl + inv_hom_id := by + simp only [← Functor.map_comp, Iso.inv_hom_id] + rfl }⟩ + +def isoExtAsSmallClosedType : + Ty.{v,max u (v+2)} + ≅ U.{v+1,max u (v+2)}.ext U.asSmallClosedType.{v, max u (v+2)} where + hom := (Grpd.homOf isoExtAsSmallClosedTypeHom.{v,u}) + inv := (Grpd.homOf isoExtAsSmallClosedTypeInv.{v,u}) + hom_inv_id := rfl + inv_hom_id := rfl + +end U + +def liftSeqObjs (i : Nat) (h : i < 4) : Universe Grpd.{4} := + match i with + | 0 => U.{0,4} + | 1 => U.{1,4} + | 2 => U.{2,4} + | 3 => U.{3,4} + | (n+4) => by omega + +open CategoryTheory Opposite + +section + +variable {Γ : Grpd} {C : Type (v+1)} [Category.{v} C] {Δ : Grpd} (σ : Δ ⟶ Γ) + +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 + apply (U.disp_pullback A).hom_ext + · rw [substWk_var] + simp [var, Grpd.comp_eq_comp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, Functor.assoc, pre_toPGrpd, + map_eqToHom_toPGrpd] + · rw [substWk_disp] + simp [Grpd.comp_eq_comp, Functor.assoc] + erw [pre_comp_forget, ← Functor.assoc, map_forget] + +@[simp] theorem sec_eq {Γ : Ctx} (α : Γ ⟶ U.{v}.Tm) (A : Γ ⟶ U.{v}.Ty) (hα : α ≫ U.tp = A) : + U.sec _ α hα = sec (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv α) + (by rw [← hα, Grpd.comp_eq_comp, tp, toCoreAsSmallEquiv_apply_comp_right]) := by + apply (U.disp_pullback _).hom_ext + . erw [Universe.sec_var, U_var, var, Grpd.comp_eq_comp, + ← toCoreAsSmallEquiv_symm_apply_comp_left, Equiv.eq_symm_apply, sec_toPGrpd] + rfl + . rw [sec_disp] + rfl + +end U + +end + +end GroupoidModel + +end diff --git a/HoTTLean/Model/Interpretation.lean b/HoTTLean/Model/Interpretation.lean index 4adc0f79..ac4cfa28 100644 --- a/HoTTLean/Model/Interpretation.lean +++ b/HoTTLean/Model/Interpretation.lean @@ -16,8 +16,9 @@ open CategoryTheory Limits noncomputable section -namespace NaturalModel.Universe -open SynthLean +namespace StructuredModel.Universe + +open SynthLean UnstructuredModel.Universe variable {𝒞 : Type u} [Category 𝒞] {R : MorphismProperty 𝒞} (M : Universe R) @@ -119,7 +120,7 @@ theorem substWk_length {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : s.ExtSeq Γ Γ') @[functor_map (attr := reassoc)] theorem substWk_disp {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : s.ExtSeq Γ Γ') : (d.substWk σ).2.2 ≫ d.disp = (d.substWk σ).2.1.disp ≫ σ := by - induction d generalizing σ <;> simp [substWk, NaturalModel.Universe.substWk_disp_assoc, *] + induction d generalizing σ <;> simp [substWk, UnstructuredModel.Universe.substWk_disp_assoc, *] /-- `Γ.Aₖ.….A₀ ⊢ vₙ : Aₙ[↑ⁿ⁺¹]` -/ protected def var {Γ Γ' : 𝒞} {l : Nat} (llen : l < s.length + 1) : @@ -199,7 +200,7 @@ theorem var_substWk_of_lt_length {l i} {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : obtain ⟨a, amem, rfl⟩ := st_mem refine ⟨_, ih amem h, ?_⟩ simp only [← Category.assoc] - simp [NaturalModel.Universe.substWk_disp] + simp [UnstructuredModel.Universe.substWk_disp] end ExtSeq @@ -392,7 +393,7 @@ def ofTerm (Γ : s.CObj) (l : Nat) : | .code t, _ => Part.assert (0 < l) fun lpos => do let A ← ofType Γ (l-1) t - return cast (by congr 3; omega) <| s.code (by omega) A + return cast (by congr 3; sorry) <| s.code (by omega) A | _, _ => .none end @@ -1336,4 +1337,4 @@ def snoc [DecidableEq χ] (I : Interpretation χ s) (c : χ) (l : Nat) (l_lt : l ax d k _ := if h : c = d ∧ k = l then some (h.2 ▸ sc) else I.ax d k end Interpretation -end NaturalModel.Universe +end StructuredModel.Universe diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/StructuredModel.lean similarity index 90% rename from HoTTLean/Model/NaturalModel.lean rename to HoTTLean/Model/StructuredModel.lean index 813dce9f..cd512e40 100644 --- a/HoTTLean/Model/NaturalModel.lean +++ b/HoTTLean/Model/StructuredModel.lean @@ -4,7 +4,7 @@ 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 +import HoTTLean.Model.UnstructuredModel universe v u @@ -12,7 +12,7 @@ noncomputable section open CategoryTheory Limits Opposite -namespace NaturalModel +namespace StructuredModel /-- A natural model with support for dependent types (and nothing more). The data is a natural transformation with representable fibers, @@ -21,6 +21,8 @@ structure Universe {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) extends UnstructuredModel.Universe Ctx where morphismProperty : R tp +-- FIXME: rename `Universe.toUniverse` to `Univese.toUnstructured` + namespace Universe open UnstructuredModel.Universe @@ -293,8 +295,8 @@ def mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : M.ext A ⟶ N.Ty) (β apply (disp_pullback ..).hom_ext <;> simp) @[simp] -theorem fst_mk (α : Γ ⟶ M.Tm) {A} (eq : α ≫ M.tp = A) (B : (M.ext A) ⟶ N.Ty) (β : Γ ⟶ N.Tm) - (h : β ≫ N.tp = (M.sec _ α eq) ≫ B) : fst (mk α eq B β h) = α := by +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] @@ -529,20 +531,117 @@ theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty end -def ofUnstructured (U0 U1 U2 : Universe R) - (S : UnstructuredModel.Universe.PolymorphicSigma U0.toUniverse U1.toUniverse U2.toUniverse) : - PolymorphicSigma U0 U1 U2 where - Sig := ofYoneda (fun AB => S.Sig (PtpEquiv.snd U0 AB)) (by - intro Δ Γ σ A - simp only [← S.Sig_comp, PtpEquiv.snd_comp_left, PtpEquiv.fst_comp_left] - rw! [PtpEquiv.fst_comp_left]) - pair := ofYoneda (fun ab => S.pair (compDomEquiv.dependent ab) (compDomEquiv.fst ab) - (by rw [compDomEquiv.fst_tp]) (compDomEquiv.snd ab) (by rw [compDomEquiv.snd_tp])) (by - intro Δ Γ σ A - simp only [← S.pair_comp, compDomEquiv.comp_dependent, compDomEquiv.fst_comp, +section + +variable {U0 U1 U2 : Universe R} + (S : UnstructuredModel.Universe.PolymorphicSigma U0.toUniverse U1.toUniverse U2.toUniverse) + +def ofUnstructured.SigApp (AB : Γ ⟶ U0.Ptp.obj U1.Ty) : Γ ⟶ U2.Ty := + S.Sig (PtpEquiv.snd U0 AB) + +lemma ofUnstructured.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 ofUnstructured.Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty := + ofYoneda (SigApp S) (Sig_naturality S) + +def ofUnstructured.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 ofUnstructured.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]) - Sig_pullback := sorry + rw! [compDomEquiv.fst_comp, Category.assoc] + +def ofUnstructured.pair : U0.compDom U1 ⟶ U2.Tm := + ofYoneda (pairApp S) (pair_naturality S) + +lemma ofUnstructured.pair_tp (ab : Γ ⟶ U0.compDom U1) : + ofUnstructured.pairApp S ab ≫ U2.tp = ofUnstructured.SigApp S (ab ≫ U0.compP U1) := by + dsimp [pairApp, SigApp] + rw! [S.pair_tp, compDomEquiv.dependent_eq, compDomEquiv.fst_tp] + +def ofUnstructured.lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.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 ofUnstructured.fst_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.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 ofUnstructured.snd_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.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 ofUnstructured.dependent_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.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 ofUnstructured.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 ofUnstructured.lift_compP (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : + ofUnstructured.lift S ab AB ab_tp ≫ U0.compP U1 = AB := by + dsimp [lift] + rw [compDomEquiv.mk_comp, PtpEquiv.eta] + +lemma ofUnstructured.lift_uniq (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) + (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) (m : Γ ⟶ U0.compDom U1) + (hl : ofUnstructured.pairApp S m = ab) (hr : m ≫ U0.compP U1 = AB) : + m = ofUnstructured.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] + +def ofUnstructured : 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 end PolymorphicSigma @@ -1385,4 +1484,4 @@ end Id' end Universe -end NaturalModel +end StructuredModel diff --git a/HoTTLean/Model/UHom.lean b/HoTTLean/Model/UHom.lean index 276392c6..2b9f2a7b 100644 --- a/HoTTLean/Model/UHom.lean +++ b/HoTTLean/Model/UHom.lean @@ -1,7 +1,7 @@ import Mathlib.CategoryTheory.Limits.Shapes.StrictInitial import HoTTLean.ForMathlib import HoTTLean.ForPoly -import HoTTLean.Model.NaturalModel +import HoTTLean.Model.StructuredModel /-! Morphisms of natural models, and Russell-universe embeddings. -/ @@ -11,15 +11,20 @@ noncomputable section open CategoryTheory Limits Opposite MonoidalCategory -namespace NaturalModel +namespace StructuredModel namespace Universe open UnstructuredModel.Universe -variable {Ctx : Type u} [Category Ctx] - {R : MorphismProperty Ctx} (M : Universe R) +variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} + (M : StructuredModel.Universe R) + +variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] [R.HasPullbacks] [R.IsStableUnderBaseChange] + [R.HasPushforwards R] [R.IsStableUnderPushforward R] + +open ChosenTerminal macro "by>" s:tacticSeq : term => `(by as_aux_lemma => $s) @@ -63,38 +68,11 @@ def Hom.subst (M : Universe R) pb := by convert IsPullback.of_right' (M.disp_pullback Aσ) (M.disp_pullback A)} -variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] - [R.HasPushforwards R] [R.IsStableUnderPushforward R] - -def Hom.cartesianNatTrans {M N : Universe R} (h : Hom M N) : - M.Ptp ⟶ N.Ptp := - M.uvPolyTp.cartesianNatTrans N.uvPolyTp h.mapTy h.mapTm h.pb - @[simp] def Hom.extIsoExt {M N : Universe R} (h : Hom M N) - {Γ} (A : (Γ) ⟶ M.Ty) : (N.ext (A ≫ h.mapTy)) ≅ (M.ext A) := - IsPullback.isoIsPullback N.Tm (Γ) (N.disp_pullback (A ≫ h.mapTy)) + {Γ} (A : Γ ⟶ M.Ty) : (N.ext (A ≫ h.mapTy)) ≅ (M.ext A) := + IsPullback.isoIsPullback N.Tm Γ (N.disp_pullback (A ≫ h.mapTy)) (IsPullback.paste_horiz (M.disp_pullback A) h.pb) -@[reassoc] -theorem Hom.mk_comp_cartesianNatTrans {M N : Universe R} (h : Hom M N) - {Γ X} (A : (Γ) ⟶ M.Ty) (B : (M.ext A) ⟶ X) : - PtpEquiv.mk M A B ≫ h.cartesianNatTrans.app X = - PtpEquiv.mk N (A ≫ h.mapTy) ((h.extIsoExt A).hom ≫ B) := by sorry - -- simp [PtpEquiv.mk] - -- have := UvPoly.Equiv.mk'_comp_cartesianNatTrans_app M.uvPolyTp (P' := N.uvPolyTp) - -- A _ _ _ (M.disp_pullback _).flip B h.mapTm h.mapTy h.pb.flip - -- refine this.trans ?_ - -- simp [UvPoly.Equiv.mk']; congr 1 - -- rw [← Category.assoc]; congr 1 - -- generalize_proofs _ h1 - -- apply h1.hom_ext <;> simp - -/- We have a 'nice', specific terminal object in `Ctx`, -and this instance allows use to use it directly -rather than through an isomorphism with `Limits.terminal`. -/ -variable [ChosenTerminal Ctx] -open ChosenTerminal - /-- A Russell universe embedding is a hom of natural models `M ⟶ N` such that types in `M` correspond to terms of a universe `U` in `N`. @@ -239,6 +217,97 @@ theorem substCons_unliftVar {i j ij jlen Γ A} {A' : (Γ) ⟶ s[j].Ty} ≫ s.unliftVar i j ij jlen A eq = t := by simp [unlift, unliftVar]; apply (s.homOfLe i j).pb.hom_ext <;> simp [*] +/-- +TODO: Consider generalising to just UHom? +Convert a map into the `i`th type classifier into a a term of the +`i+1`th term classifier, that is a term of the `i`th universe. +It is defined by composition with the first projection of the pullback square + v + s[i].Ty ----> s[i+1].Tm + ^ | | + A / | p.b. | + / | | + / V V +(Γ) ---> 1 -----> s[i+1].Ty + U_i +-/ +def code {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : + (Γ) ⟶ s[i+1].Tm := + A ≫ (s.homSucc i).asTm + +@[simp] +theorem code_tp {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : + s.code ilen A ≫ s[i+1].tp = (s.homSucc i).wkU Γ := by + simp [code, (s.homSucc i).U_pb.w, UHom.wkU] + +@[reassoc] +theorem comp_code {Δ Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) + (σ : (Δ) ⟶ (Γ)) (A : (Γ) ⟶ s[i].Ty) : + σ ≫ s.code ilen A = s.code ilen (σ ≫ A) := by + simp [code] + +/-- +TODO: Consider generalising to just UHom? +Convert a a term of the `i`th universe (it is a `i+1` level term) into +a map into the `i`th type classifier. +It is the unique map into the pullback + a +(Γ) -----------------¬ +‖ --> v V +‖ s[i].Ty ----> s[i+1].Tm +‖ | | +‖ | p.b. | +‖ | | +‖ V V +(Γ) ---> 1 -----> s[i+1].Ty + U_i +-/ +def el (s : UHomSeq R) {Γ : Ctx} {i : Nat} (ilen : i < s.length) + (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : + (Γ) ⟶ s[i].Ty := + (s.homSucc i).U_pb.lift a (ChosenTerminal.isTerminal.from (Γ)) (by rw [a_tp, UHom.wkU]) + +@[reassoc] +theorem comp_el (s : UHomSeq R) {Δ Γ : Ctx} {i : Nat} (ilen : i < s.length) + (σ : (Δ) ⟶ (Γ)) (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : + σ ≫ s.el ilen a a_tp = s.el ilen (σ ≫ a) (by simp [a_tp]) := + (s.homSucc i).U_pb.hom_ext (by simp [el]) (by simp) + +@[simp] +lemma el_code {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : + el s ilen (code s ilen A) (code_tp _ _ _) = A := + (s.homSucc i).U_pb.hom_ext (by simp [el, code]) (by simp) + +@[simp] +lemma code_el (s : UHomSeq R) {Γ : Ctx} {i : Nat} (ilen : i < s.length) + (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : + code s ilen (el s ilen a a_tp) = a := by + simp [code, el] + +end UHomSeq + +def Hom.cartesianNatTrans {M N : StructuredModel.Universe R} (h : Hom M N) : + M.Ptp ⟶ N.Ptp := + M.uvPolyTp.cartesianNatTrans N.uvPolyTp h.mapTy h.mapTm h.pb + +@[reassoc] +theorem Hom.mk_comp_cartesianNatTrans {M N : StructuredModel.Universe R} + (h : Hom M N) {Γ X} (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : + PtpEquiv.mk M A B ≫ h.cartesianNatTrans.app X = + PtpEquiv.mk N (A ≫ h.mapTy) ((h.extIsoExt A).hom ≫ B) := by sorry + -- simp [PtpEquiv.mk] + -- have := UvPoly.Equiv.mk'_comp_cartesianNatTrans_app M.uvPolyTp (P' := N.uvPolyTp) + -- A _ _ _ (M.disp_pullback _).flip B h.mapTm h.mapTy h.pb.flip + -- refine this.trans ?_ + -- simp [UvPoly.Equiv.mk']; congr 1 + -- rw [← Category.assoc]; congr 1 + -- generalize_proofs _ h1 + -- apply h1.hom_ext <;> simp + +namespace UHomSeq + +variable (s : UHomSeq R) + /-- If `s` is a sequence of universe homomorphisms then for `i ≤ j` we get a polynomial endofunctor natural transformation `s[i].Ptp ⟶ s[j].Ptp`. @@ -336,73 +405,6 @@ theorem hom_comp_trans (s : UHomSeq R) (i j k : Nat) (ij : i < j) (jk : j < k) . rw [UHom.comp_assoc, hom_comp_trans] termination_by s.length - i -/-- -TODO: Consider generalising to just UHom? -Convert a map into the `i`th type classifier into a a term of the -`i+1`th term classifier, that is a term of the `i`th universe. -It is defined by composition with the first projection of the pullback square - v - s[i].Ty ----> s[i+1].Tm - ^ | | - A / | p.b. | - / | | - / V V -(Γ) ---> 1 -----> s[i+1].Ty - U_i --/ -def code {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : - (Γ) ⟶ s[i+1].Tm := - A ≫ (s.homSucc i).asTm - -@[simp] -theorem code_tp {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : - s.code ilen A ≫ s[i+1].tp = (s.homSucc i).wkU Γ := by - simp [code, (s.homSucc i).U_pb.w, UHom.wkU] - -@[reassoc] -theorem comp_code {Δ Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) - (σ : (Δ) ⟶ (Γ)) (A : (Γ) ⟶ s[i].Ty) : - σ ≫ s.code ilen A = s.code ilen (σ ≫ A) := by - simp [code] - -/-- -TODO: Consider generalising to just UHom? -Convert a a term of the `i`th universe (it is a `i+1` level term) into -a map into the `i`th type classifier. -It is the unique map into the pullback - a -(Γ) -----------------¬ -‖ --> v V -‖ s[i].Ty ----> s[i+1].Tm -‖ | | -‖ | p.b. | -‖ | | -‖ V V -(Γ) ---> 1 -----> s[i+1].Ty - U_i --/ -def el (s : UHomSeq R) {Γ : Ctx} {i : Nat} (ilen : i < s.length) - (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : - (Γ) ⟶ s[i].Ty := - (s.homSucc i).U_pb.lift a (ChosenTerminal.isTerminal.from (Γ)) (by rw [a_tp, UHom.wkU]) - -@[reassoc] -theorem comp_el (s : UHomSeq R) {Δ Γ : Ctx} {i : Nat} (ilen : i < s.length) - (σ : (Δ) ⟶ (Γ)) (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : - σ ≫ s.el ilen a a_tp = s.el ilen (σ ≫ a) (by simp [a_tp]) := - (s.homSucc i).U_pb.hom_ext (by simp [el]) (by simp) - -@[simp] -lemma el_code {Γ : Ctx} {i : Nat} (s : UHomSeq R) (ilen : i < s.length) (A : (Γ) ⟶ s[i].Ty) : - el s ilen (code s ilen A) (code_tp _ _ _) = A := - (s.homSucc i).U_pb.hom_ext (by simp [el, code]) (by simp) - -@[simp] -lemma code_el (s : UHomSeq R) {Γ : Ctx} {i : Nat} (ilen : i < s.length) - (a : (Γ) ⟶ s[i+1].Tm) (a_tp : a ≫ s[i+1].tp = (s.homSucc i).wkU Γ) : - code s ilen (el s ilen a a_tp) = a := by - simp [code, el] - -- Sadly, we have to spell out `ilen` and `jlen` due to -- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Optional.20implicit.20argument variable {i j : Nat} (ilen : i < s.length + 1) (jlen : j < s.length + 1) diff --git a/HoTTLean/Model/Unstructured.lean b/HoTTLean/Model/UnstructuredModel.lean similarity index 79% rename from HoTTLean/Model/Unstructured.lean rename to HoTTLean/Model/UnstructuredModel.lean index 38068ecb..099f6e6f 100644 --- a/HoTTLean/Model/Unstructured.lean +++ b/HoTTLean/Model/UnstructuredModel.lean @@ -3,7 +3,6 @@ import HoTTLean.ForMathlib import HoTTLean.ForMathlib.Tactic.CategoryTheory.FunctorMap import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone import HoTTLean.ForMathlib.CategoryTheory.WeakPullback -import HoTTLean.ForMathlib.CategoryTheory.Polynomial universe u v @@ -239,39 +238,6 @@ structure PolymorphicSigma (U0 U1 U2 : Universe Ctx) where (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) --- def Sigma.mk'' {U0 U1 U2 : Universe R} --- (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_tp : 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_tp : s ≫ U2.tp = Sig B), Γ ⟶ U0.Tm) --- (fst_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} --- (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = Sig B), --- fst (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by cat_disch) = σ ≫ fst B s s_tp) --- (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_tp : s ≫ U2.tp = Sig B), Γ ⟶ U1.Tm) --- (snd_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} --- (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = Sig B), --- snd (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by cat_disch) = σ ≫ snd B s s_tp) --- (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 : sorry) --- (snd_pair : sorry) --- (eta : sorry) --- : PolymorphicSigma U0 U1 U2 := --- sorry +end Universe + +end UnstructuredModel From 77742a166630ccc72235cda8ca366fae82fd242b Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 2 Oct 2025 17:45:08 -0400 Subject: [PATCH 18/59] refactor pi through unstructured API --- HoTTLean.lean | 1 - .../ForMathlib/CategoryTheory/NatTrans.lean | 116 +++++++ .../ForMathlib/CategoryTheory/Polynomial.lean | 126 +++++-- HoTTLean/Groupoids/NaturalModelBase.lean | 0 HoTTLean/Groupoids/Pi.lean | 319 +++++++++-------- HoTTLean/Groupoids/Sigma.lean | 40 ++- HoTTLean/Groupoids/StructuredModel.lean | 16 +- HoTTLean/Model/NaturalModel.lean | 0 HoTTLean/Model/StructuredModel.lean | 326 ++++++++++++++++-- HoTTLean/Model/UnstructuredModel.lean | 26 ++ lake-manifest.json | 2 +- 11 files changed, 757 insertions(+), 215 deletions(-) create mode 100644 HoTTLean/Groupoids/NaturalModelBase.lean create mode 100644 HoTTLean/Model/NaturalModel.lean diff --git a/HoTTLean.lean b/HoTTLean.lean index c644b86e..78a1c802 100644 --- a/HoTTLean.lean +++ b/HoTTLean.lean @@ -1,5 +1,4 @@ import HoTTLean.Model.Interpretation -import HoTTLean.Groupoids.NaturalModelBase import HoTTLean.Groupoids.Sigma import HoTTLean.Groupoids.Pi import HoTTLean.Groupoids.Id diff --git a/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean b/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean index d816e232..91b709b5 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean @@ -1,3 +1,6 @@ +import Mathlib.CategoryTheory.NatTrans +import Mathlib.CategoryTheory.Functor.TwoSquare +import Mathlib.CategoryTheory.Limits.Shapes.Pullback.CommSq import HoTTLean.ForMathlib universe w v u v₁ u₁ v₂ u₂ v₃ u₃ @@ -34,3 +37,116 @@ instance {A : Type*} [Category A] {B : Type*} [Groupoid B] : comp_inv := NatTrans.vcomp_inv end CategoryTheory + + +/- +Copyright (c) 2025 Sina Hazratpour. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Sina Hazratpour +-/ + +open CategoryTheory Limits IsPullback + +namespace CategoryTheory + +universe v' 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 + +open Functor + +/-- A natural transformation is *cartesian* +if all its naturality squares are pullbacks. -/ +def IsCartesian {F G : J ⥤ C} (α : F ⟶ G) : Prop := + ∀ ⦃i j : J⦄ (f : i ⟶ j), IsPullback (F.map f) (α.app i) (α.app j) (G.map f) + +theorem isCartesian_of_isIso {F G : J ⥤ C} (α : F ⟶ G) [IsIso α] : IsCartesian α := + fun _ _ f => IsPullback.of_vert_isIso ⟨NatTrans.naturality _ f⟩ + +theorem isIso_of_isCartesian [HasTerminal J] {F G : J ⥤ C} (α : F ⟶ G) (hα : IsCartesian α) + [IsIso (α.app (⊤_ J))] : IsIso α := by + refine @NatIso.isIso_of_isIso_app _ _ _ _ _ _ α + (fun j ↦ isIso_snd_of_isIso <| hα <| terminal.from j) + +theorem isCartesian_of_discrete {ι : Type*} {F G : Discrete ι ⥤ C} + (α : F ⟶ G) : IsCartesian α := by + rintro ⟨i⟩ ⟨j⟩ ⟨⟨rfl : i = j⟩⟩ + simp only [Discrete.functor_map_id] + exact IsPullback.of_horiz_isIso ⟨by rw [Category.id_comp, Category.comp_id]⟩ + +theorem isCartesian_of_isPullback_to_terminal [HasTerminal J] {F G : J ⥤ C} (α : F ⟶ G) + (pb : ∀ j, + IsPullback (F.map (terminal.from j)) (α.app j) (α.app (⊤_ J)) (G.map (terminal.from j))) : + IsCartesian α := by + intro i j f + apply IsPullback.of_right (h₁₂ := F.map (terminal.from j)) (h₂₂ := G.map (terminal.from j)) + simpa [← F.map_comp, ← G.map_comp] using (pb i) + exact α.naturality f + exact pb j + +namespace IsCartesian + +theorem comp {F G H : J ⥤ C} {α : F ⟶ G} {β : G ⟶ H} (hα : IsCartesian α) (hβ : IsCartesian β) : + IsCartesian (α ≫ β) := + fun _ _ f => (hα f).paste_vert (hβ f) + +theorem whiskerRight {F G : J ⥤ C} {α : F ⟶ G} (hα : IsCartesian α) (H : C ⥤ D) + [∀ (i j : J) (f : j ⟶ i), PreservesLimit (cospan (α.app i) (G.map f)) H] : + IsCartesian (whiskerRight α H) := + fun _ _ f => (hα f).map H + +theorem whiskerLeft {K : Type*} [Category K] {F G : J ⥤ C} + {α : F ⟶ G} (hα : IsCartesian α) (H : K ⥤ J) : IsCartesian (whiskerLeft H α) := + fun _ _ f => hα (H.map f) + +theorem hcomp {K : Type*} [Category K] {F G : J ⥤ C} {M N : C ⥤ K} {α : F ⟶ G} {β : M ⟶ N} + (hα : IsCartesian α) (hβ : IsCartesian β) + [∀ (i j : J) (f : j ⟶ i), PreservesLimit (cospan (α.app i) (G.map f)) M] : + IsCartesian (NatTrans.hcomp α β) := by + have ha := hα.whiskerRight M + have hb := hβ.whiskerLeft G + have hc := ha.comp hb + unfold IsCartesian + intros i j f + specialize hc f + simp only [Functor.comp_obj, Functor.comp_map, comp_app, + whiskerRight_app, whiskerLeft_app, + naturality] at hc + exact hc + +open TwoSquare + +universe v₄ v₅ v₆ v₇ v₈ u₄ u₅ u₆ u₇ u₈ + +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 vComp {w : TwoSquare T L R B} {w' : TwoSquare B L' R'' B''} + [∀ (i j : C₁) (f : j ⟶ i), PreservesLimit (cospan (w.app i) ((L ⋙ B).map f)) R''] : + IsCartesian w → IsCartesian w' → IsCartesian (w ≫ᵥ w') := + fun cw cw' => + (isCartesian_of_isIso _).comp <| + (cw.whiskerRight _).comp <| + (isCartesian_of_isIso _).comp <| + (cw'.whiskerLeft _).comp <| + (isCartesian_of_isIso _) + +theorem hComp {w : TwoSquare T L R B} {w' : TwoSquare T' R R' B'} + [∀ (i j : C₁) (f : j ⟶ i), PreservesLimit (cospan (w.app i) ((L ⋙ B).map f)) B'] : + IsCartesian w → IsCartesian w' → IsCartesian (w ≫ₕ w') := + fun cw cw' => + (isCartesian_of_isIso _).comp <| + (cw'.whiskerLeft _).comp <| + (isCartesian_of_isIso _).comp <| + (cw.whiskerRight _).comp <| + (isCartesian_of_isIso _) + +end IsCartesian +end NatTrans diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 4e5f4d44..6f281851 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -6,9 +6,10 @@ Authors: Joseph Hua, Sina Hazratpour, Emily Riehl import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction import Mathlib.CategoryTheory.Functor.TwoSquare -import Mathlib.CategoryTheory.NatTrans.IsCartesian import Mathlib.CategoryTheory.Comma.Over.Pushforward +import Mathlib.CategoryTheory.Limits.Constructions.Over.Basic import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.CategoryTheory.NatTrans universe v u v₁ u₁ @@ -70,11 +71,11 @@ def pullbackMapTwoSquare {T : Type u} [Category.{v} T] (R : MorphismProperty T) 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) + (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 @@ -178,6 +179,61 @@ theorem pushforwardPullbackTwoSquare_isIso {T : Type u} [Category.{v} T] (R : Mo (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} @@ -564,11 +620,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 ⊤ ⋯) +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] - have : (MorphismProperty.Over.pullback R ⊤ P.i.1).IsRightAdjoint := - Adjunction.isRightAdjoint (MorphismProperty.Over.mapPullbackAdj R ⊤ P.i.1 P.i.2 trivial) infer_instance /-- A commutative triangle @@ -677,33 +740,38 @@ 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 -theorem _root_.CategoryTheory.NatTrans.IsCartesian.comp' {J : Type*} [Category J] - {F G H : J ⥤ C} {α : F ⟶ G} {β : G ⟶ H} (hα : α.IsCartesian) (hβ : β.IsCartesian) : - (α ≫ β).IsCartesian := inferInstance - -theorem _root_.CategoryTheory.NatTrans.IsCartesian.of_isIso' {J : Type*} [Category J] - {F G : J ⥤ C} (α : F ⟶ G) [IsIso α] : - α.IsCartesian := inferInstance - --- TODO: use Sina's Poly ForMathlib files, not the `clan` branch of Mathlib. --- JH changed IsCartesian to an instance, which proves to be difficult to work with. 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] - 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] - -- apply IsCartesian.comp'; apply IsCartesian.of_isIso' - -- apply IsCartesian.comp' - -- · apply IsCartesian.whiskerRight - -- · apply isCartesian_mapPullbackAdj_counit - -- . apply isCartesian_of_isIso - sorry - infer_instance + -- 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 diff --git a/HoTTLean/Groupoids/NaturalModelBase.lean b/HoTTLean/Groupoids/NaturalModelBase.lean new file mode 100644 index 00000000..e69de29b diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index 9ac5c0ca..bd692e9a 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -1,5 +1,4 @@ import HoTTLean.Groupoids.Sigma -import HoTTLean.Model.NaturalModel import HoTTLean.ForMathlib.CategoryTheory.Whiskering import HoTTLean.ForMathlib.CategoryTheory.NatTrans @@ -112,7 +111,7 @@ end CategoryTheory namespace GroupoidModel -open CategoryTheory NaturalModel Universe Opposite Functor.Groupoidal +open CategoryTheory Opposite Functor.Groupoidal end GroupoidModel @@ -121,7 +120,7 @@ end ForOther -- NOTE content for this doc starts here namespace GroupoidModel -open CategoryTheory NaturalModel Universe Opposite Functor.Groupoidal +open CategoryTheory Opposite Functor.Groupoidal attribute [local simp] eqToHom_map Grpd.id_eq_id Grpd.comp_eq_comp Functor.id_comp Functor.comp_id @@ -427,8 +426,11 @@ 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 := @@ -450,6 +452,78 @@ def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := Pseudofunctor.Grothendieck.map (strongTrans B s hs) ⋙ Functor.Grothendieck.toPseudoFunctor'Iso.inv _ +lemma _root_.CategoryTheory.Functor.Grothendieck.toPseudofunctor'Iso_inv_map {Γ : Type*} + [Category Γ] (F G : Γ ⥤ Cat) (α : F ⟶ G) : + Functor.Grothendieck.toPseudoFunctor'Iso.inv F ⋙ Functor.Grothendieck.map α = + Pseudofunctor.Grothendieck.map α.toStrongTrans' ⋙ + Functor.Grothendieck.toPseudoFunctor'Iso.inv G := + sorry + +section + +variable {𝒮 : Type u₁} {𝒮' : Type u₂} [Category.{v₁} 𝒮] [Category.{v₂} 𝒮'] + (F : Pseudofunctor (LocallyDiscrete 𝒮) Cat.{v₂, u₂}) + (G : Pseudofunctor (LocallyDiscrete 𝒮') (LocallyDiscrete 𝒮)) + +open Pseudofunctor.Grothendieck + +def _root_.CategoryTheory.Pseudofunctor.Grothendieck.pre : + ∫ G.comp F ⥤ ∫ F := sorry + +end + +lemma _root_.CategoryTheory.Functor.Grothendieck.toPseudofunctor'Iso_inv_pre {Δ : Type u₁} + {Γ : Type u₂} [Category.{v₁} Δ] [Category.{v₂} Γ] (F : Γ ⥤ Cat) (σ : Δ ⥤ Γ) : + Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ F) ⋙ Functor.Grothendieck.pre F σ = + Pseudofunctor.Grothendieck.map (sorry) ⋙ + Pseudofunctor.Grothendieck.pre F.toPseudoFunctor' σ.toPseudoFunctor ⋙ + Functor.Grothendieck.toPseudoFunctor'Iso.inv F := + sorry + +-- lemma _root_.CategoryTheory.Functor.Groupoidal.toPseudoFunctor'Iso_inv_map {Γ : Type*} +-- [Groupoid Γ] (F G : Γ ⥤ Grpd) (α : F ⟶ G) : +-- Functor.Grothendieck.toPseudoFunctor'Iso.inv (F ⋙ Grpd.forgetToCat) ⋙ +-- Functor.Grothendieck.map (Functor.whiskerRight α Grpd.forgetToCat) = +-- Pseudofunctor.Grothendieck.map (Functor.whiskerRight α Grpd.forgetToCat).toStrongTrans' ⋙ +-- Functor.Grothendieck.toPseudoFunctor'Iso.inv (G ⋙ Grpd.forgetToCat) := +-- Functor.Grothendieck.toPseudoFunctor'Iso_inv_map .. + +lemma mapStrongTrans_comp : + mapStrongTrans (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) ⋙ + map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ = + pre A σ ⋙ mapStrongTrans B s hs := + calc mapStrongTrans (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) ⋙ + map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ + _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ + Pseudofunctor.Grothendieck.map (strongTrans (pre A σ ⋙ B) (σ ⋙ s) + (by simp [Functor.assoc, hs, pi_naturality])) ⋙ + (Pseudofunctor.Grothendieck.map (NatTrans.toStrongTrans' _ _ + (eqToHom (by rw [← Functor.assoc, sigma_naturality]))) ⋙ + Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ sigma A B ⋙ Grpd.forgetToCat)) ⋙ + pre (sigma A B) σ := by + rw [mapStrongTrans, ← Functor.assoc, ← Functor.Grothendieck.toPseudofunctor'Iso_inv_map] + simp [Functor.Groupoidal, Functor.Groupoidal.map, Functor.assoc] + _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ + Pseudofunctor.Grothendieck.map (strongTrans (pre A σ ⋙ B) (σ ⋙ s) + (by simp [Functor.assoc, hs, pi_naturality])) ⋙ + Pseudofunctor.Grothendieck.map (NatTrans.toStrongTrans' _ _ + (eqToHom (by rw [← Functor.assoc, sigma_naturality]))) ⋙ + Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ sigma A B ⋙ Grpd.forgetToCat) ⋙ + pre (sigma A B) σ := by + simp [Functor.assoc] + -- _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ + -- Pseudofunctor.Grothendieck.map (Oplax.StrongTrans.comp (strongTrans (pre A σ ⋙ B) (σ ⋙ s) sorry) sorry) ⋙ + -- Pseudofunctor.Grothendieck.pre (sigma A B ⋙ + -- Grpd.forgetToCat).toPseudoFunctor' σ.toPseudoFunctor ⋙ + -- Functor.Grothendieck.toPseudoFunctor'Iso.inv (sigma A B ⋙ Grpd.forgetToCat) := by + -- dsimp [pre] + -- rw [Functor.Grothendieck.toPseudofunctor'Iso_inv_pre] + -- simp [Functor.assoc] + -- rw [Pseudofunctor.Grothendieck.map_comp_eq] + -- sorry + _ = pre A σ ⋙ mapStrongTrans B s hs := by + sorry + /-- 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` @@ -491,7 +565,16 @@ lemma ι_comp_inversion {x} : ι A x ⋙ inversion B s hs = · intro a b h sorry -end pi +lemma inversion_comp : pi.inversion (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) = + pre A σ ⋙ pi.inversion B s hs := by + dsimp [inversion] + rw [← pre_toPGrpd] + conv => left; right; rw [← Functor.assoc, sigma.assoc_pre] + simp only [← Functor.assoc] + congr 2 + rw [Functor.assoc, mapStrongTrans_comp] + +end section @@ -818,13 +901,23 @@ 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 +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 @@ -858,7 +951,7 @@ lemma lamMapFiber_inversion_heq {x y} (f : x ⟶ y) : lamMapFiber A (pi.inversion B s hs) f ≍ PGrpd.mapFiber s f := sorry -lemma pi.eta : lam A (inversion B s hs) = s := by +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 @@ -867,159 +960,99 @@ lemma pi.eta : lam A (inversion B s hs) = s := by end end + +end pi + end FunctorOperation section variable {Γ : Ctx} -/- -namespace smallUPi - open FunctorOperation -def Pi_app (AB : y(Γ) ⟶ smallU.{v}.Ptp.obj smallU.{v}.Ty) : - y(Γ) ⟶ smallU.{v}.Ty := - --by - --#check (smallU.PtpEquiv.fst AB) - -- #check (smallU.PtpEquiv.snd AB) - yonedaCategoryEquiv.symm (pi _ (smallU.PtpEquiv.snd AB)) - -def Pi_naturality {Δ Γ} (f : Δ ⟶ Γ) (α : y(Γ) ⟶ smallU.Ptp.obj smallU.Ty) : - Pi_app (ym(f) ≫ α) = ym(f) ≫ Pi_app α := by - dsimp only [Pi_app] - rw [← yonedaCategoryEquiv_symm_naturality_left, pi_naturality, - smallU.PtpEquiv.snd_comp_left] - rw! [smallU.PtpEquiv.fst_comp_left] - simp [map_id_eq, Functor.id_comp] - -/-- The formation rule for Π-types for the natural model `smallU` -/ -def Pi : smallU.{v}.Ptp.obj smallU.{v}.Ty ⟶ smallU.{v}.Ty := - NatTrans.yonedaMk Pi_app Pi_naturality - -lemma Pi_app_eq {Γ : Ctx} (ab : y(Γ) ⟶ _) : ab ≫ Pi = - yonedaCategoryEquiv.symm (FunctorOperation.pi _ (smallU.PtpEquiv.snd ab)) := by - rw [Pi, NatTrans.yonedaMk_app, Pi_app] - -def lam_app (ab : y(Γ) ⟶ smallU.{v}.Ptp.obj smallU.{v}.Tm) : - y(Γ) ⟶ smallU.{v}.Tm := - yonedaCategoryEquiv.symm (lam _ (smallU.PtpEquiv.snd ab)) - -open smallU.PtpEquiv - -def lam_naturality {Δ Γ} (f : Δ ⟶ Γ) (α : y(Γ) ⟶ smallU.Ptp.obj smallU.Tm) : - lam_app (ym(f) ≫ α) = ym(f) ≫ lam_app α := by - dsimp only [lam_app] - rw [← yonedaCategoryEquiv_symm_naturality_left, FunctorOperation.lam_naturality] - rw! [snd_comp_left, fst_comp_left] - simp [map_id_eq] - -/-- The introduction rule for Π-types for the natural model `smallU` -/ -def lam : smallU.{v}.Ptp.obj smallU.{v}.Tm ⟶ smallU.{v}.Tm := - NatTrans.yonedaMk lam_app lam_naturality - -lemma lam_app_eq {Γ : Ctx} (ab : y(Γ) ⟶ smallU.Ptp.obj smallU.Tm) : ab ≫ lam = - yonedaCategoryEquiv.symm (FunctorOperation.lam _ (smallU.PtpEquiv.snd ab)) := by - rw [lam, NatTrans.yonedaMk_app, lam_app] - +namespace UPi -/-lemma smallUSig.pair_app_eq {Γ : Ctx} (ab : y(Γ) ⟶ _) : ab ≫ smallUSig.pair = - yonedaCategoryEquiv.symm (FunctorOperation.pair _ _ _ (snd_forgetToGrpd ab)) := by - simp only [smallUSig.pair, smallUSig.pair_app, NatTrans.yonedaMk_app] +def Pi {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := + USig.SigAux pi B -namespace SigPullback +/-- 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 -open Limits +def lam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (b : U.ext A ⟶ U.{v}.Tm) : Γ ⟶ U.{v}.Tm := + USig.SigAux pi.lam b -section +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 -theorem smallUSig.pair_tp : smallUSig.pair.{v} ≫ smallU.{v}.tp = - smallU.comp.{v} ≫ smallUSig.Sig.{v} := by - apply hom_ext_yoneda - intros Γ ab - rw [← Category.assoc, ← Category.assoc, smallUSig.pair_app_eq, - smallUSig.Sig_app_eq, smallU_tp, π, - ← yonedaCategoryEquiv_symm_naturality_right, - pair_comp_forgetToGrpd, smallUSig.Sig_app] - congr 2 - · rw [fst_forgetToGrpd] - · exact dependent_heq.{v} ab --/ +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 -theorem lam_tp : smallUPi.lam ≫ smallU.tp = smallU.Ptp.map smallU.tp ≫ Pi := by - apply hom_ext_yoneda - intros Γ ab - rw [← Category.assoc, ← Category.assoc, lam_app_eq, Pi_app_eq, smallU_tp, π, - ← yonedaCategoryEquiv_symm_naturality_right, lam_comp_forgetToGrpd] - symm; congr 2 - · apply smallU.PtpEquiv.fst_app_comp_map_tp - · apply smallU.PtpEquiv.snd_app_comp_map_tp +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_comp {Γ Δ : Ctx.{max u (v+1)}} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} + (eq : σ ≫ A = σA) {B : U.ext A ⟶ U.Ty} (f : Γ ⟶ U.Tm) + (f_tp : f ≫ U.tp = UPi.Pi B) : UPi.unLam (U.substWk σ A σA eq ≫ B) (σ ≫ f) + (by rw [Category.assoc, f_tp, Pi_comp]) = U.substWk σ A σA eq ≫ UPi.unLam B f f_tp := by + dsimp [unLam] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left] + congr 1 + subst eq + conv => right; rw! [U.substWk_eq, Functor.assoc] + simp [map_id_eq, U.substWk_eq] + rw [← pi.inversion_comp] + rfl -section -variable {Γ : Ctx} (AB : y(Γ) ⟶ smallU.Ptp.obj.{v} y(U.{v})) - (s : y(Γ) ⟶ y(E.{v})) (hs : s ≫ ym(π) = AB ≫ smallUPi.Pi) - -include hs in -theorem yonedaCategoryEquiv_forgetToGrpd : yonedaCategoryEquiv s ⋙ PGrpd.forgetToGrpd - = pi (smallU.PtpEquiv.fst AB) (smallU.PtpEquiv.snd AB) := by - erw [← yonedaCategoryEquiv_naturality_right, hs] - rw [smallUPi.Pi_app_eq, yonedaCategoryEquiv.apply_symm_apply] - -def lift : y(Γ) ⟶ smallU.Ptp.obj.{v} smallU.Tm.{v} := - have hs' : yonedaCategoryEquiv s ⋙ PGrpd.forgetToGrpd = pi (fst AB) (snd AB) := by - erw [← yonedaCategoryEquiv_naturality_right, hs] - rw [Pi_app_eq, yonedaCategoryEquiv.apply_symm_apply] - mk (fst AB) (pi.inversion (snd AB) (yonedaCategoryEquiv s) hs') - -theorem fac_left : lift.{v} AB s hs ≫ lam.{v} = s := by - rw [lam_app_eq, yonedaCategoryEquiv.symm_apply_eq] - dsimp only [lift] - conv => left; right; rw! [smallU.PtpEquiv.snd_mk] - rw! [smallU.PtpEquiv.fst_mk] - simp [map_id_eq, pi.eta] - -theorem fac_right : lift.{v} AB s hs ≫ smallU.Ptp.{v}.map smallU.tp = AB := by - apply smallU.PtpEquiv.hext - · sorry - · sorry +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 -theorem hom_ext (m n : y(Γ) ⟶ smallU.Ptp.{v}.obj smallU.Tm.{v}) - (hMap : m ≫ smallU.Ptp.{v}.map smallU.tp.{v} = n ≫ smallU.Ptp.{v}.map smallU.tp.{v}) - (hLam : m ≫ lam.{v} = n ≫ lam) : m = n := by - sorry +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 -end +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 : UnstructuredModel.Universe.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_comp := UPi.unLam_comp + unLam_tp := UPi.unLam_tp + unLam_lam := UPi.unLam_lam + lam_unLam := UPi.lam_unLam --- TODO: is this the best way to do universe levels? -theorem isPullback : IsPullback lam.{v, max u (v+1)} - (smallU.Ptp.{v, max u (v+1)}.map smallU.tp.{v, max u (v+1)}) - smallU.{v, max u (v+1)}.tp Pi.{v, max u (v+1)} := - Limits.RepPullbackCone.is_pullback lam_tp - (fun s => lift.{v, max u (v+1)} s.snd s.fst s.condition) - (fun s => fac_left.{v, max u (v+1)} s.snd s.fst s.condition) - (fun s => fac_right.{v, max u (v+1)} s.snd s.fst s.condition) - (fun s m hml hmr => - hom_ext.{v, max u (v+1)} m (lift.{v, max u (v+1)} s.snd s.fst s.condition) - (by rw [hmr, fac_right.{v, max u (v+1)}]) (by rw [hml, fac_left.{v, max u (v+1)}])) - -end smallUPi - -def smallUPi : Universe.Pi smallU.{v} where - Pi := smallUPi.Pi.{v} - lam := smallUPi.lam.{v} - Pi_pullback := smallUPi.isPullback.{v} - -def uHomSeqPis' (i : ℕ) (ilen : i < 4) : - Universe.Pi (uHomSeqObjs i ilen) := - match i with - | 0 => smallUPi.{0,4} - | 1 => smallUPi.{1,4} - | 2 => smallUPi.{2,4} - | 3 => smallUPi.{3,4} - | (n+4) => by omega - -instance uHomSeqPi : uHomSeq.PiSeq where - nmPi := uHomSeqPis' --/ end end GroupoidModel diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index a252ce84..1d3d2371 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -836,20 +836,24 @@ open FunctorOperation section -def USig.Sig {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := - toCoreAsSmallEquiv.symm (sigma _ (toCoreAsSmallEquiv B)) - -/-- -Naturality for the formation rule for Σ-types. -Also known as Beck-Chevalley. --/ -theorem USig.Sig_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} - (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) : - USig.Sig (U.substWk σ A σA eq ≫ B) = σ ≫ USig.Sig B := by - simp only [USig.Sig, Grpd.comp_eq_comp] +@[simp] +abbrev USig.SigAux {X : Type (v + 1)} [Category.{v} X] + (S : ∀ {Γ : Ctx} (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ X), Γ ⥤ X) + {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ Ctx.coreAsSmall X) : + Γ ⟶ Ctx.coreAsSmall X := + toCoreAsSmallEquiv.symm (S (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv B)) + +theorem USig.SigAux_comp {X : Type (v + 1)} [Category.{v} X] + (S : ∀ {Γ : Ctx} (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ X), Γ ⥤ X) + (S_naturality : ∀ {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⥤ Grpd} + {B : ∫(A) ⥤ X}, σ ⋙ S A B = S (σ ⋙ A) (pre A σ ⋙ B)) + {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} + (eq : σ ≫ A = σA) (B : U.ext A ⟶ Ctx.coreAsSmall X) : + USig.SigAux S (U.substWk σ A σA eq ≫ B) = σ ≫ USig.SigAux S B := by + simp only [USig.SigAux, Grpd.comp_eq_comp] rw [← toCoreAsSmallEquiv_symm_apply_comp_left] congr 1 - rw [sigma_naturality] + rw [S_naturality] subst eq simp only [Grpd.comp_eq_comp] conv => left; right; rw! [toCoreAsSmallEquiv_apply_comp_left] @@ -857,6 +861,18 @@ theorem USig.Sig_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA simp [U.substWk_eq, map_id_eq] rfl +def USig.Sig {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := + USig.SigAux sigma B + +/-- +Naturality for the formation rule for Σ-types. +Also known as Beck-Chevalley. +-/ +theorem USig.Sig_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} + (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) : + USig.Sig (U.substWk σ A σA eq ≫ B) = σ ≫ USig.Sig B := + USig.SigAux_comp sigma (by intros; rw [sigma_naturality]) σ eq B + lemma USig.pair_aux {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : toCoreAsSmallEquiv b ⋙ forgetToGrpd = diff --git a/HoTTLean/Groupoids/StructuredModel.lean b/HoTTLean/Groupoids/StructuredModel.lean index c355fd56..21077e6f 100644 --- a/HoTTLean/Groupoids/StructuredModel.lean +++ b/HoTTLean/Groupoids/StructuredModel.lean @@ -1,4 +1,4 @@ -import HoTTLean.Groupoids.Sigma +import HoTTLean.Groupoids.Pi /-! Here we construct universes for the groupoid natural model. @@ -63,6 +63,9 @@ def liftSeq : UHomSeq Grpd.IsIsofibration.{5} where def USig : Universe.Sigma StructuredU := PolymorphicSigma.ofUnstructured GroupoidModel.USig +def smallUPi : Universe.Pi StructuredU := + PolymorphicPi.ofUnstructured GroupoidModel.UPi + #exit def liftSeqSigs' (i : ℕ) (ilen : i < 4) : Universe.Sigma (liftSeqObjs i ilen) := @@ -76,6 +79,17 @@ def liftSeqSigs' (i : ℕ) (ilen : i < 4) : instance liftSeqSigma : liftSeq.SigSeq where nmSig := liftSeqSigs' +def uHomSeqPis' (i : ℕ) (ilen : i < 4) : + Universe.Pi (uHomSeqObjs i ilen) := + match i with + | 0 => smallUPi.{0,4} + | 1 => smallUPi.{1,4} + | 2 => smallUPi.{2,4} + | 3 => smallUPi.{3,4} + | (n+4) => by omega + +instance uHomSeqPi : uHomSeq.PiSeq where + nmPi := uHomSeqPis' -- section diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean new file mode 100644 index 00000000..e69de29b diff --git a/HoTTLean/Model/StructuredModel.lean b/HoTTLean/Model/StructuredModel.lean index cd512e40..75508b24 100644 --- a/HoTTLean/Model/StructuredModel.lean +++ b/HoTTLean/Model/StructuredModel.lean @@ -373,6 +373,274 @@ Ptp Ty ------> Ty -/ protected abbrev Pi := PolymorphicPi M M M +namespace PolymorphicPi + +variable {U0 U1 U2 : Universe 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 + simp [substWk] + +/-- +``` +Γ ⊢₀ 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 : + UnstructuredModel.Universe.PolymorphicPi U0.toUniverse U1.toUniverse U2.toUniverse 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_comp σ A σA eq _ f f_tp := (P.comp_unLam σ A σA eq _ f f_tp).symm + 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 : Universe R} + (P : UnstructuredModel.Universe.PolymorphicPi U0.toUniverse U1.toUniverse U2.toUniverse) + +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 : UnstructuredModel.Universe.PolymorphicPi U0.toUniverse U1.toUniverse + U2.toUniverse) : 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 @@ -531,82 +799,82 @@ theorem mkPair_mkFst_mkSnd {Γ : Ctx} (A : Γ ⟶ U0.Ty) (B : U0.ext A ⟶ U1.Ty end -section +namespace ofUnstructured variable {U0 U1 U2 : Universe R} (S : UnstructuredModel.Universe.PolymorphicSigma U0.toUniverse U1.toUniverse U2.toUniverse) -def ofUnstructured.SigApp (AB : Γ ⟶ U0.Ptp.obj U1.Ty) : Γ ⟶ U2.Ty := +def SigApp (AB : Γ ⟶ U0.Ptp.obj U1.Ty) : Γ ⟶ U2.Ty := S.Sig (PtpEquiv.snd U0 AB) -lemma ofUnstructured.Sig_naturality {Δ Γ} (σ : Δ ⟶ Γ) (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 ofUnstructured.Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty := +def Sig : U0.Ptp.obj U1.Ty ⟶ U2.Ty := ofYoneda (SigApp S) (Sig_naturality S) -def ofUnstructured.pairApp (ab : Γ ⟶ U0.compDom U1) : Γ ⟶ U2.Tm := +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 ofUnstructured.pair_naturality {Δ Γ} (σ : Δ ⟶ Γ) (ab) : +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 ofUnstructured.pair : U0.compDom U1 ⟶ U2.Tm := +def pair : U0.compDom U1 ⟶ U2.Tm := ofYoneda (pairApp S) (pair_naturality S) -lemma ofUnstructured.pair_tp (ab : Γ ⟶ U0.compDom U1) : - ofUnstructured.pairApp S ab ≫ U2.tp = ofUnstructured.SigApp S (ab ≫ U0.compP U1) := by +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 ofUnstructured.lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) - (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : +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 ofUnstructured.fst_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) - (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : +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 ofUnstructured.snd_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) - (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : +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 ofUnstructured.dependent_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) - (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : +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 ofUnstructured.pairApp_lift (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) +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 ofUnstructured.lift_compP (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) - (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) : - ofUnstructured.lift S ab AB ab_tp ≫ U0.compP U1 = AB := by +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 ofUnstructured.lift_uniq (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) - (ab_tp : ab ≫ U2.tp = ofUnstructured.SigApp S AB) (m : Γ ⟶ U0.compDom U1) - (hl : ofUnstructured.pairApp S m = ab) (hr : m ≫ U0.compP U1 = AB) : - m = ofUnstructured.lift S ab AB ab_tp := by +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] @@ -632,7 +900,11 @@ lemma ofUnstructured.lift_uniq (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1 subst hl hr rw! [compDomEquiv.dependent_eq, compDomEquiv.fst_tp] -def ofUnstructured : PolymorphicSigma U0 U1 U2 where +end ofUnstructured + +def ofUnstructured {U0 U1 U2 : Universe R} + (S : UnstructuredModel.Universe.PolymorphicSigma U0.toUniverse U1.toUniverse U2.toUniverse) : + PolymorphicSigma U0 U1 U2 where Sig := ofUnstructured.Sig S pair := ofUnstructured.pair S Sig_pullback := ofYoneda_isPullback _ _ _ _ _ _ (ofUnstructured.pair_tp S) @@ -641,8 +913,6 @@ def ofUnstructured : PolymorphicSigma U0 U1 U2 where (ofUnstructured.lift_compP S) (ofUnstructured.lift_uniq S) -end - end PolymorphicSigma -- def Sigma.mk' diff --git a/HoTTLean/Model/UnstructuredModel.lean b/HoTTLean/Model/UnstructuredModel.lean index 099f6e6f..dc21da8a 100644 --- a/HoTTLean/Model/UnstructuredModel.lean +++ b/HoTTLean/Model/UnstructuredModel.lean @@ -238,6 +238,32 @@ structure PolymorphicSigma (U0 U1 U2 : Universe Ctx) where (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) +structure PolymorphicPi (U0 U1 U2 : Universe 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_tp : 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_tp : f ≫ U2.tp = Pi B), U0.ext A ⟶ U1.Tm) + (unLam_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} + (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = Pi B), + unLam (U0.substWk σ A σA eq ≫ B) (σ ≫ f) (by cat_disch) = + U0.substWk σ A σA eq ≫ unLam B f f_tp) + (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) + end Universe end UnstructuredModel diff --git a/lake-manifest.json b/lake-manifest.json index 662e80b9..2325d4c8 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -15,7 +15,7 @@ "type": "git", "subDir": null, "scope": "", - "rev": "87d8a903c4d5ede38bf6685dede04722bbc755b4", + "rev": "df0f5040c2944a4c4d4fd353185776a9d2af3e03", "name": "mathlib", "manifestFile": "lake-manifest.json", "inputRev": "clans", From 168533908807c8d5811976b02e09820a54f78501 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 3 Oct 2025 16:45:16 -0400 Subject: [PATCH 19/59] feat: isofibration pushforward proof skeleton --- .../CategoryTheory/IsIsofibration.lean | 25 -- HoTTLean/Groupoids/Id.lean | 4 +- HoTTLean/Groupoids/IsIsofibration.lean | 216 ++++++++++ HoTTLean/Groupoids/Pi.lean | 2 +- HoTTLean/Groupoids/Sigma.lean | 4 +- HoTTLean/Groupoids/StructuredModel.lean | 58 +-- HoTTLean/Groupoids/UnstructuredModel.lean | 8 +- HoTTLean/Model/Interpretation.lean | 57 +-- HoTTLean/Model/StructuredModel.lean | 74 ++-- HoTTLean/Model/UHom.lean | 376 +++++++++--------- HoTTLean/Model/UnstructuredModel.lean | 20 +- .../Groupoids => attic}/SigmaBackup.lean | 0 12 files changed, 524 insertions(+), 320 deletions(-) create mode 100644 HoTTLean/Groupoids/IsIsofibration.lean rename {HoTTLean/Groupoids => attic}/SigmaBackup.lean (100%) diff --git a/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean index 4d7a07a3..e69de29b 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean @@ -1,25 +0,0 @@ -import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction -import HoTTLean.ForMathlib.CategoryTheory.Grpd -import HoTTLean.ForMathlib.CategoryTheory.FreeGroupoid - -universe w v u v₁ u₁ v₂ u₂ v₃ u₃ - -namespace CategoryTheory -namespace Grpd - -instance : Grpd.IsIsofibration.IsStableUnderBaseChange := by - dsimp [IsIsofibration] - infer_instance - -instance : Grpd.IsIsofibration.HasObjects := by - sorry - -instance : Grpd.IsIsofibration.IsMultiplicative := by - dsimp [IsIsofibration] - infer_instance - -instance : Grpd.IsIsofibration.HasPushforwards Grpd.IsIsofibration := - sorry - -instance : Grpd.IsIsofibration.IsStableUnderPushforward Grpd.IsIsofibration := - sorry diff --git a/HoTTLean/Groupoids/Id.lean b/HoTTLean/Groupoids/Id.lean index 2f4a6a4a..9a13ca49 100644 --- a/HoTTLean/Groupoids/Id.lean +++ b/HoTTLean/Groupoids/Id.lean @@ -1,4 +1,4 @@ -import HoTTLean.Groupoids.NaturalModelBase +import HoTTLean.Groupoids.UnstructuredModel import HoTTLean.Model.NaturalModel @@ -93,7 +93,7 @@ end CategoryTheory namespace GroupoidModel -open CategoryTheory Functor.Groupoidal NaturalModel Universe +open CategoryTheory Functor.Groupoidal namespace FunctorOperation diff --git a/HoTTLean/Groupoids/IsIsofibration.lean b/HoTTLean/Groupoids/IsIsofibration.lean new file mode 100644 index 00000000..aed03597 --- /dev/null +++ b/HoTTLean/Groupoids/IsIsofibration.lean @@ -0,0 +1,216 @@ +import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction +import Mathlib.CategoryTheory.FiberedCategory.HomLift +import Mathlib.CategoryTheory.FiberedCategory.Fiber +import HoTTLean.ForMathlib.CategoryTheory.Grpd +import HoTTLean.ForMathlib.CategoryTheory.FreeGroupoid +import HoTTLean.Groupoids.Pi + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section + +namespace GroupoidModel.FunctorOperation.pi + +open CategoryTheory Functor.Groupoidal + +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_naturality])) + (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_naturality, 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] + +-- TODO: work out naturality equations for this bijection + +end GroupoidModel.FunctorOperation.pi + +namespace CategoryTheory + +open Functor.Groupoidal + +structure Functor.Isofibration {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' + is_hom_lift_hom {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : + F.IsHomLift f (liftIso f hX') + +namespace Functor.Isofibration + +variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} + (hF : F.Isofibration) + +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 + +/-- Any isofibration `F : E ⥤ Γ` of groupoids is classified by a functor `classifier : Γ ⥤ Grpd`. +-/ +def classifier : Γ ⥤ Grpd.{v,u} where + obj X := Grpd.of (F.Fiber X) + map := + have : Isofibration F := hF -- TODO: remove. This is just to ensure variables used + sorry -- use lifting of isomorphisms! + map_id := sorry + map_comp := sorry + +/-- The Grothendieck construction on the classifier is isomorphic to `E`. +TODO: add commuting triangles for `Grothendieck.forget` and `F` with `.hom` and `.inv`. +TODO: draw pullback diagram. -/ +def grothendieckClassifierIso : ∫ classifier hF ≅≅ E where + hom := + sorry + inv := sorry + hom_inv_id := sorry + inv_hom_id := sorry + +end Functor.Isofibration + +namespace Grpd + +attribute [simp] comp_eq_comp id_eq_id in +@[simps] +def Grpd.mkIso {Δ Γ : Grpd} (F : Δ ≅≅ Γ) : Δ ≅ Γ where + hom := F.hom + inv := F.inv + hom_inv_id := by simp + inv_hom_id := by simp + +namespace IsIsofibration + +def isofibration {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : F.Isofibration := sorry + +/-- The Grothendieck construction on the classifier is isomorphic to `E`, +now as objects in `Grpd`. -/ +def grothendieckClassifierIso {E Γ : Grpd} {F : E ⟶ Γ} (hF : IsIsofibration F) : + Grpd.of (∫ hF.isofibration.classifier) ≅ E := + Grpd.mkIso (Functor.Isofibration.grothendieckClassifierIso ..) + +end IsIsofibration + +instance : IsIsofibration.IsStableUnderBaseChange := by + dsimp [IsIsofibration] + infer_instance + +instance : IsIsofibration.IsMultiplicative := by + dsimp [IsIsofibration] + infer_instance + +instance : IsIsofibration.HasObjects := by + sorry + +section + +attribute [local instance] Grpd.IsIsofibration.isofibration + +open Functor.Isofibration + +def strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : C ⟶ (Grpd.of <| ∫ classifier (hF.isofibration)) := + sorry + +lemma isIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsIsofibration (strictify hF hG) := sorry + +/-- 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : Grpd := + Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.isofibration.classifier) + (classifier (isIsofibration_strictify hF hG).isofibration)) + +/-- 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : Over A := + Over.mk (pushforwardHom hF hG) + +-- This is one step towards the equivalence `pushforwardHomEquiv` +def pushforwardHomEquivAux {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (X : Over A) : + (X ⟶ pushforward hF hG) ≃ + (f : ∫ X.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isIsofibration_strictify hF hG).isofibration.classifier) ×' + (f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier X.hom) where + toFun f := ⟨GroupoidModel.FunctorOperation.pi.equivFun (σ := X.hom) _ f.left f.w, + GroupoidModel.FunctorOperation.pi.equivFun_comp_forget (σ := X.hom) _ f.left f.w⟩ + invFun := sorry + left_inv := sorry + right_inv := sorry + +/-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ +def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (X : Over A) : + (X ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj X ⟶ Over.mk G) := by + dsimp [pushforward, pushforwardHom] + sorry + +/-- Naturality in the universal property of the pushforward. -/ +lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration 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 + sorry + +instance : IsIsofibration.HasPushforwards IsIsofibration := + fun F _ G => { + has_representation := ⟨pushforward F.2 G.2, ⟨{ + homEquiv := pushforwardHomEquiv .. + homEquiv_comp f g := pushforwardHomEquiv_comp F.2 G.2 f g }⟩⟩ } + +-- This should follow from `Groupoidal.forget` being an isofibration. +-- (If we manage to directly define the pushforward +-- as a grothendieck construction) +theorem isIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsIsofibration (pushforwardHom hF hG) := + sorry + +/- 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. Isofibrations are stable under isomorphism (this is in mathlib, for any `rlp`) + `MorphismProperty.rlp_isMultiplicative` + `MorphismProperty.respectsIso_of_isStableUnderComposition` + 3. The chosen pushforward is an isofibration `isIsofibration_pushforward` -/ +instance : IsIsofibration.IsStableUnderPushforward IsIsofibration where + of_isPushforward F G P := sorry diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index bd692e9a..9ac367f2 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -1041,7 +1041,7 @@ lemma lam_unLam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (f : Γ end UPi -def UPi : UnstructuredModel.Universe.PolymorphicPi U.{v} U.{v} U.{v} where +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 diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index 1d3d2371..7f16c9b0 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -7,7 +7,7 @@ noncomputable section namespace GroupoidModel -open CategoryTheory UnstructuredModel Universe Opposite Functor.Groupoidal PGrpd +open CategoryTheory Model UnstructuredUniverse Opposite Functor.Groupoidal PGrpd attribute [local simp] eqToHom_map Grpd.id_eq_id Grpd.comp_eq_comp Functor.id_comp @@ -1014,7 +1014,7 @@ lemma USig.eta {Γ : Grpd} {A : Γ ⟶ U.Ty} (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ congr 1 simp [sigma.dependent', map_id_eq] -def USig : Universe.PolymorphicSigma U.{v} U.{v} U.{v} where +def USig : PolymorphicSigma U.{v} U.{v} U.{v} where Sig := USig.Sig Sig_comp := USig.Sig_comp pair := USig.pair diff --git a/HoTTLean/Groupoids/StructuredModel.lean b/HoTTLean/Groupoids/StructuredModel.lean index 21077e6f..990deddf 100644 --- a/HoTTLean/Groupoids/StructuredModel.lean +++ b/HoTTLean/Groupoids/StructuredModel.lean @@ -1,4 +1,4 @@ -import HoTTLean.Groupoids.Pi +import HoTTLean.Groupoids.IsIsofibration /-! Here we construct universes for the groupoid natural model. @@ -7,7 +7,7 @@ Here we construct universes for the groupoid natural model. universe w v u v₁ u₁ v₂ u₂ v₃ u₃ noncomputable section -open CategoryTheory Limits UnstructuredModel StructuredModel Universe +open CategoryTheory Limits Model UnstructuredUniverse StructuredUniverse Functor.Groupoidal GroupoidModel.Ctx GroupoidModel.U namespace GroupoidModel @@ -18,7 +18,7 @@ open U The π-clan we use is the set of groupoid isofibrations. -/ @[simps!] -def StructuredU : Universe Grpd.IsIsofibration where +def StructuredU : StructuredUniverse Grpd.IsIsofibration where __ := U morphismProperty := sorry @@ -26,7 +26,7 @@ namespace U open MonoidalCategory -def liftSeqObjs (i : Nat) (h : i < 4) : Universe Grpd.IsIsofibration.{5} := +def liftSeqObjs (i : Nat) (h : i < 4) : StructuredUniverse Grpd.IsIsofibration.{5} := match i with | 0 => StructuredU.{0,4} | 1 => StructuredU.{1,4} @@ -60,15 +60,15 @@ def liftSeq : UHomSeq Grpd.IsIsofibration.{5} where objs := liftSeqObjs homSucc' := liftSeqHomSucc' -def USig : Universe.Sigma StructuredU := +def USig : StructuredUniverse.Sigma StructuredU := PolymorphicSigma.ofUnstructured GroupoidModel.USig -def smallUPi : Universe.Pi StructuredU := +def smallUPi : StructuredUniverse.Pi StructuredU := PolymorphicPi.ofUnstructured GroupoidModel.UPi #exit def liftSeqSigs' (i : ℕ) (ilen : i < 4) : - Universe.Sigma (liftSeqObjs i ilen) := + StructuredUniverse.Sigma (liftSeqObjs i ilen) := match i with | 0 => USig.{0, 4} | 1 => USig.{1, 4} @@ -80,7 +80,7 @@ instance liftSeqSigma : liftSeq.SigSeq where nmSig := liftSeqSigs' def uHomSeqPis' (i : ℕ) (ilen : i < 4) : - Universe.Pi (uHomSeqObjs i ilen) := + StructuredUniverse.Pi (uHomSeqObjs i ilen) := match i with | 0 => smallUPi.{0,4} | 1 => smallUPi.{1,4} @@ -106,7 +106,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- `PtpEquiv.fst` is the `A` in this pair. -- -/ -- def fst : Γ ⥤ Grpd.{v,v} := --- toCoreAsSmallEquiv (Universe.PtpEquiv.fst U AB) +-- toCoreAsSmallEquiv (StructuredUniverse.PtpEquiv.fst U AB) -- variable (A := fst AB) (hA : A = fst AB := by rfl) @@ -117,8 +117,8 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- `PtpEquiv.snd` is the `B` in this pair. -- -/ -- def snd : ∫A ⥤ C := --- toCoreAsSmallEquiv (Universe.PtpEquiv.snd U AB (toCoreAsSmallEquiv.symm A) (by --- simp [Universe.PtpEquiv.fst, hA, fst])) +-- toCoreAsSmallEquiv (StructuredUniverse.PtpEquiv.snd U AB (toCoreAsSmallEquiv.symm A) (by +-- simp [StructuredUniverse.PtpEquiv.fst, hA, fst])) -- nonrec theorem fst_comp_left : fst (σ ≫ AB) = σ ⋙ fst AB := by -- dsimp only [fst] @@ -127,7 +127,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- theorem fst_comp_right {D : Type (v + 1)} [Category.{v, v + 1} D] (F : C ⥤ D) : -- fst (AB ≫ U.Ptp.map (Ctx.coreAsSmallFunctor F)) = fst AB := by -- dsimp only [fst] --- rw [Universe.PtpEquiv.fst_comp_right] +-- rw [StructuredUniverse.PtpEquiv.fst_comp_right] -- nonrec theorem snd_comp_left : snd (σ ≫ AB) (σ ⋙ A) (by rw [hA, fst_comp_left]) = -- map (eqToHom (by rw [hA])) ⋙ pre _ σ ⋙ snd AB := by @@ -146,14 +146,14 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- -/ -- def mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : -- Γ ⟶ U.{v}.Ptp.obj (Ctx.coreAsSmall C) := --- Universe.PtpEquiv.mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B) +-- StructuredUniverse.PtpEquiv.mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B) -- theorem hext (AB1 AB2 : Γ ⟶ U.{v}.Ptp.obj Ty.{v}) (hfst : fst AB1 = fst AB2) -- (hsnd : HEq (snd AB1) (snd AB2)) : AB1 = AB2 := by --- have hfst' : Universe.PtpEquiv.fst U AB1 = Universe.PtpEquiv.fst U AB2 := by +-- have hfst' : StructuredUniverse.PtpEquiv.fst U AB1 = StructuredUniverse.PtpEquiv.fst U AB2 := by -- dsimp [fst] at hfst -- aesop --- apply Universe.PtpEquiv.ext U (Universe.PtpEquiv.fst U AB1) ?_ hfst' ?_ +-- apply StructuredUniverse.PtpEquiv.ext U (StructuredUniverse.PtpEquiv.fst U AB1) ?_ hfst' ?_ -- · simp -- · dsimp only [snd] at hsnd -- apply toCoreAsSmallEquiv.injective @@ -164,7 +164,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- @[simp] -- lemma fst_mk (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ C) : -- fst (mk A B) = A := by --- simp [fst, mk, Universe.PtpEquiv.fst_mk] +-- simp [fst, mk, StructuredUniverse.PtpEquiv.fst_mk] -- lemma Grpd.eqToHom_comp_heq {A B : Grpd} {C : Type*} [Category C] -- (h : A = B) (F : B ⥤ C) : eqToHom h ⋙ F ≍ F := by @@ -175,7 +175,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- snd (mk A B) A' (by rw [fst_mk, hA]) = map (eqToHom hA.symm) ⋙ B := by -- dsimp only [snd, mk] -- subst hA --- rw [Universe.PtpEquiv.snd_mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B)] +-- rw [StructuredUniverse.PtpEquiv.snd_mk U (toCoreAsSmallEquiv.symm A) (toCoreAsSmallEquiv.symm B)] -- erw [Equiv.apply_symm_apply toCoreAsSmallEquiv B] -- simp [map_id_eq] @@ -189,7 +189,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- @[simp] -- abbrev compP : compDom.{v} ⟶ U.{v}.Ptp.obj Ty.{v} := --- Universe.compP U U +-- StructuredUniverse.compP U U -- namespace compDom @@ -202,7 +202,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- is `(a : A)` in `(a : A) × (b : B a)`. -- -/ -- def fst : Γ ⥤ PGrpd.{v,v} := --- toCoreAsSmallEquiv (Universe.compDomEquiv.fst ab) +-- toCoreAsSmallEquiv (StructuredUniverse.compDomEquiv.fst ab) -- /-- Universal property of `compDom`, decomposition (part 2). @@ -212,7 +212,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- -/ -- def dependent (A := fst ab ⋙ PGrpd.forgetToGrpd) (eq : fst ab ⋙ PGrpd.forgetToGrpd = A := by rfl) : -- ∫(A) ⥤ Grpd.{v,v} := --- toCoreAsSmallEquiv (Universe.compDomEquiv.dependent ab (toCoreAsSmallEquiv.symm A) (by +-- toCoreAsSmallEquiv (StructuredUniverse.compDomEquiv.dependent ab (toCoreAsSmallEquiv.symm A) (by -- simp only [U_Ty, U_Tm, compDomEquiv.fst, U_tp, ← eq] -- erw [toCoreAsSmallEquiv_symm_apply_comp_right] -- simp [fst]; rfl)) @@ -224,7 +224,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- is `(b : B a)` in `(a : A) × (b : B a)`. -- -/ -- def snd : Γ ⥤ PGrpd.{v,v} := --- toCoreAsSmallEquiv (Universe.compDomEquiv.snd ab) +-- toCoreAsSmallEquiv (StructuredUniverse.compDomEquiv.snd ab) -- /-- Universal property of `compDom`, decomposition (part 4). @@ -235,7 +235,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- -/ -- theorem snd_forgetToGrpd : snd ab ⋙ PGrpd.forgetToGrpd = sec _ (fst ab) rfl ⋙ (dependent ab) := by -- erw [← toCoreAsSmallEquiv_apply_comp_right, ← Grpd.comp_eq_comp, --- Universe.compDomEquiv.snd_tp ab, sec_eq] +-- StructuredUniverse.compDomEquiv.snd_tp ab, sec_eq] -- rfl -- /-- Universal property of `compDom`, constructing a map into `compDom`. -/ @@ -244,7 +244,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- (B : ∫(A) ⥤ Grpd.{v,v}) -- (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : -- Γ ⟶ compDom.{v} := --- Universe.compDomEquiv.mk (toCoreAsSmallEquiv.symm α) (A := toCoreAsSmallEquiv.symm A) +-- StructuredUniverse.compDomEquiv.mk (toCoreAsSmallEquiv.symm α) (A := toCoreAsSmallEquiv.symm A) -- (by rw [← hA, toCoreAsSmallEquiv_symm_apply_comp_right]; rfl) -- (toCoreAsSmallEquiv.symm B) (toCoreAsSmallEquiv.symm β) -- (by @@ -265,7 +265,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- (eq : fst ab ⋙ PGrpd.forgetToGrpd = A := by rfl) : dependent ab A eq = -- map (eqToHom (by rw [← eq, fst_forgetToGrpd])) ⋙ U.PtpEquiv.snd (ab ≫ compP.{v}) := by -- dsimp only [dependent, PtpEquiv.snd] --- rw [Universe.compDomEquiv.dependent_eq _ _ _, ← toCoreAsSmallEquiv_apply_comp_left] +-- rw [StructuredUniverse.compDomEquiv.dependent_eq _ _ _, ← toCoreAsSmallEquiv_apply_comp_left] -- subst eq -- rw! [← fst_forgetToGrpd] -- simp [map_id_eq] @@ -279,21 +279,21 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- theorem fst_comp : fst (σ ≫ ab) = σ ⋙ fst ab := by -- dsimp only [fst] --- rw [Universe.compDomEquiv.fst_comp, Grpd.comp_eq_comp, +-- rw [StructuredUniverse.compDomEquiv.fst_comp, Grpd.comp_eq_comp, -- toCoreAsSmallEquiv_apply_comp_left] -- theorem dependent_comp : dependent (σ ≫ ab) = -- map (eqToHom (by rw [fst_comp, Functor.assoc])) -- ⋙ pre _ σ ⋙ dependent ab := by -- rw [dependent, dependent, --- ← Universe.compDomEquiv.comp_dependent (eq1 := rfl) +-- ← StructuredUniverse.compDomEquiv.comp_dependent (eq1 := rfl) -- (eq2 := by erw [← compDomEquiv.fst_comp_assoc, fst, toCoreAsSmallEquiv.eq_symm_apply]; rfl), -- substWk_eq] -- rfl -- theorem snd_comp : snd (σ ≫ ab) = σ ⋙ snd ab := by -- dsimp only [snd] --- rw [Universe.compDomEquiv.snd_comp, Grpd.comp_eq_comp, +-- rw [StructuredUniverse.compDomEquiv.snd_comp, Grpd.comp_eq_comp, -- toCoreAsSmallEquiv_apply_comp_left] -- /-- First component of the computation rule for `mk`. -/ @@ -302,7 +302,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- (B : ∫(A) ⥤ Grpd.{v,v}) -- (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : -- fst (mk α A hA B β h) = α := by --- simp [fst, mk, Universe.compDomEquiv.fst_mk] +-- simp [fst, mk, StructuredUniverse.compDomEquiv.fst_mk] -- /-- Second component of the computation rule for `mk`. -/ -- theorem dependent_mk (α : Γ ⥤ PGrpd.{v,v}) (A := α ⋙ PGrpd.forgetToGrpd) @@ -325,7 +325,7 @@ instance uHomSeqPi : uHomSeq.PiSeq where -- (β : Γ ⥤ PGrpd.{v,v}) (h : β ⋙ PGrpd.forgetToGrpd = sec _ α hA ⋙ B) : -- snd (mk α A hA B β h) = β := by -- dsimp [snd, mk] --- rw [Universe.compDomEquiv.snd_mk] +-- rw [StructuredUniverse.compDomEquiv.snd_mk] -- simp -- theorem ext (ab1 ab2 : Γ ⟶ U.compDom.{v}) diff --git a/HoTTLean/Groupoids/UnstructuredModel.lean b/HoTTLean/Groupoids/UnstructuredModel.lean index aad9b213..f154dbea 100644 --- a/HoTTLean/Groupoids/UnstructuredModel.lean +++ b/HoTTLean/Groupoids/UnstructuredModel.lean @@ -13,7 +13,7 @@ Here we construct universes for the groupoid natural model. universe w v u v₁ u₁ v₂ u₂ v₃ u₃ noncomputable section -open CategoryTheory Limits UnstructuredModel Universe +open CategoryTheory Limits Model UnstructuredUniverse Functor.Groupoidal GroupoidModel.Ctx GroupoidModel.U namespace GroupoidModel @@ -24,7 +24,7 @@ open U The π-clan we use is the set of groupoid isofibrations. -/ @[simps] -def U : Universe Grpd where +def U : UnstructuredUniverse Grpd where Ty := Ty.{v} Tm := Tm.{v} tp := tp @@ -81,7 +81,7 @@ def isoExtAsSmallClosedType : end U -def liftSeqObjs (i : Nat) (h : i < 4) : Universe Grpd.{4} := +def liftSeqObjs (i : Nat) (h : i < 4) : UnstructuredUniverse Grpd.{4} := match i with | 0 => U.{0,4} | 1 => U.{1,4} @@ -113,7 +113,7 @@ theorem substWk_eq (A : Γ ⟶ U.Ty.{v}) (σA : Δ ⟶ U.Ty.{v}) (eq) : U.sec _ α hα = sec (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv α) (by rw [← hα, Grpd.comp_eq_comp, tp, toCoreAsSmallEquiv_apply_comp_right]) := by apply (U.disp_pullback _).hom_ext - . erw [Universe.sec_var, U_var, var, Grpd.comp_eq_comp, + . erw [sec_var, U_var, var, Grpd.comp_eq_comp, ← toCoreAsSmallEquiv_symm_apply_comp_left, Equiv.eq_symm_apply, sec_toPGrpd] rfl . rw [sec_disp] diff --git a/HoTTLean/Model/Interpretation.lean b/HoTTLean/Model/Interpretation.lean index ac4cfa28..4e6fbc57 100644 --- a/HoTTLean/Model/Interpretation.lean +++ b/HoTTLean/Model/Interpretation.lean @@ -16,12 +16,12 @@ open CategoryTheory Limits noncomputable section -namespace StructuredModel.Universe +namespace Model.StructuredUniverse -open SynthLean UnstructuredModel.Universe +open SynthLean UnstructuredUniverse variable {𝒞 : Type u} [Category 𝒞] - {R : MorphismProperty 𝒞} (M : Universe R) + {R : MorphismProperty 𝒞} (M : StructuredUniverse R) [R.HasPullbacks] [R.IsStableUnderBaseChange] variable [ChosenTerminal 𝒞] [R.HasObjects] [R.IsMultiplicative] [R.HasPushforwards R] [R.IsStableUnderPushforward R] @@ -120,7 +120,7 @@ theorem substWk_length {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : s.ExtSeq Γ Γ') @[functor_map (attr := reassoc)] theorem substWk_disp {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : s.ExtSeq Γ Γ') : (d.substWk σ).2.2 ≫ d.disp = (d.substWk σ).2.1.disp ≫ σ := by - induction d generalizing σ <;> simp [substWk, UnstructuredModel.Universe.substWk_disp_assoc, *] + induction d generalizing σ <;> simp [substWk, substWk_disp_assoc, *] /-- `Γ.Aₖ.….A₀ ⊢ vₙ : Aₙ[↑ⁿ⁺¹]` -/ protected def var {Γ Γ' : 𝒞} {l : Nat} (llen : l < s.length + 1) : @@ -200,7 +200,7 @@ theorem var_substWk_of_lt_length {l i} {Δ Γ Γ' : 𝒞} (σ : Δ ⟶ Γ) (d : obtain ⟨a, amem, rfl⟩ := st_mem refine ⟨_, ih amem h, ?_⟩ simp only [← Category.assoc] - simp [UnstructuredModel.Universe.substWk_disp] + simp [UnstructuredUniverse.substWk_disp] end ExtSeq @@ -306,7 +306,7 @@ def ofType (Γ : s.CObj) (l : Nat) : have jlen : j < s.length + 1 := by omega let A ← ofType Γ i A let B ← ofType (Γ.snoc ilen A) j B - return lij ▸ s.mkPi ilen jlen A B + return lij ▸ (s.polymorphicPi ilen jlen).mkPi A B | .sigma i j A B, _ => Part.assert (l = max i j) fun lij => do have ilen : i < s.length + 1 := by omega @@ -343,14 +343,14 @@ def ofTerm (Γ : s.CObj) (l : Nat) : have jlen : j < s.length + 1 := by omega let A ← ofType Γ i A let e ← ofTerm (Γ.snoc ilen A) j e - return lij ▸ s.mkLam ilen jlen A e + return lij ▸ (s.polymorphicPi ilen jlen).mkLam A e | .app i _ B f a, llen => do Part.assert (i < s.length + 1) fun ilen => do let f ← ofTerm Γ (max i l) f let a ← ofTerm Γ i a let B ← ofType (Γ.snoc ilen (a ≫ s[i].tp)) l B - Part.assert (f ≫ s[max i l].tp = s.mkPi ilen llen (a ≫ s[i].tp) B) fun h => - return s.mkApp ilen llen _ B f h a rfl + Part.assert (f ≫ s[max i l].tp = (s.polymorphicPi ilen llen).mkPi (a ≫ s[i].tp) B) fun h => + return (s.polymorphicPi ilen llen).mkApp _ B f h a rfl | .pair i j B t u, _ => do Part.assert (l = max i j) fun lij => do have ilen : i < s.length + 1 := by omega @@ -414,7 +414,7 @@ theorem mem_ofType_pi {Γ l i j A B} {llen : l < s.length + 1} {x} : have jlen : j < s.length + 1 := by> omega ∃ (A' : Γ.fst ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ ∃ (B' : ((Γ.snoc ilen A').fst) ⟶ s[j].Ty), B' ∈ I.ofType (Γ.snoc ilen A') j B ∧ - x = lij ▸ s.mkPi ilen jlen A' B' := by + x = lij ▸ (s.polymorphicPi ilen jlen).mkPi A' B' := by dsimp only [ofType]; simp_part; exact exists_congr fun _ => by subst l; simp_part @[simp] @@ -468,7 +468,7 @@ theorem mem_ofTerm_lam {Γ l i j A e} {llen : l < s.length + 1} {x} : have jlen : j < s.length + 1 := by> omega ∃ (A' : (Γ.1) ⟶ s[i].Ty), A' ∈ I.ofType Γ i A ∧ ∃ (e' : ((Γ.snoc ilen A').1) ⟶ s[j].Tm), e' ∈ I.ofTerm (Γ.snoc ilen A') j e ∧ - x = lij ▸ s.mkLam ilen jlen A' e' := by + x = lij ▸ (s.polymorphicPi ilen jlen).mkLam A' e' := by dsimp only [ofTerm]; simp_part; exact exists_congr fun _ => by subst l; simp_part @[simp] @@ -480,7 +480,7 @@ theorem mem_ofTerm_app {Γ l i j B f a} {llen : l < s.length + 1} {x} : ∃ A', ∃ eq : a' ≫ s[i].tp = A', ∃ B' : ((Γ.snoc ilen A').1) ⟶ s[l].Ty, B' ∈ I.ofType (Γ.snoc ilen A') l B ∧ - ∃ h, x = s.mkApp ilen llen _ B' f' h a' eq := by + ∃ h, x = (s.polymorphicPi ilen llen).mkApp _ B' f' h a' eq := by dsimp only [ofTerm]; simp_part; simp only [exists_prop_eq'] @[simp] @@ -657,7 +657,7 @@ end CSb /-! ## Admissibility of substitution -/ -open UHomSeq PolymorphicSigma +open UHomSeq PolymorphicSigma PolymorphicPi variable (slen : univMax ≤ s.length) theorem mem_ofType_ofTerm_subst' {full} @@ -962,9 +962,11 @@ theorem EqTmIH.lam {Γ A A' B t t' l l'} : obtain ⟨_, hΓ₁, _, _, hA₁, rfl⟩ := I.mem_ofCtx_snoc.1 hΓ' cases Part.mem_unique hΓ hΓ₁ cases Part.mem_unique hA hA₁ - exact ⟨_, hΓ, _, _, I.mem_ofType_pi.2 ⟨rfl, _, hA, _, hB, by simp⟩, _, - I.mem_ofTerm_lam.2 ⟨rfl, _, hA, _, ht, by simp⟩, - I.mem_ofTerm_lam.2 ⟨rfl, _, hA', _, ht', by simp⟩, mkLam_tp (t_tp := ttp) ..⟩ + sorry + -- exact ⟨_, hΓ, _, _, I.mem_ofType_pi.2 ⟨rfl, _, hA, _, hB, by simp⟩, _, + -- I.mem_ofTerm_lam.2 ⟨rfl, _, hA, _, ht, by simp⟩, + -- I.mem_ofTerm_lam.2 ⟨rfl, _, hA', _, ht', by simp⟩, + -- mkLam_tp (t_tp := ttp) ..⟩ theorem EqTmIH.app {Γ A B B' f f' a a' l l'} : I.EqTpIH ((A, l) :: Γ) l' B B' → @@ -1102,8 +1104,8 @@ theorem EqTmIH.app_lam {Γ A B t u l l'} : exact ⟨_, hΓ, _, _, I.mem_ofType_toSb _ hu utp hB, _, I.mem_ofTerm_app.2 ⟨_, _, I.mem_ofTerm_lam.2 ⟨rfl, _, hA, _, ht, by simp⟩, _, hu, _, utp, _, hB, - s.mkLam_tp (t_tp := ttp) .., - (s.mkApp_mkLam (t_tp := ttp) ..).symm⟩, + mkLam_tp (t_tp := ttp) .., + (mkApp_mkLam (t_tp := ttp) ..).symm⟩, I.mem_ofTerm_toSb _ hu _ ht, by simp [ttp]⟩ theorem EqTmIH.fst_snd_pair {Γ A B t u l l'} : @@ -1157,14 +1159,15 @@ theorem EqTmIH.lam_app {Γ A B f l l'} : (.lam l l' A (.app l l' (.subst (.up .wk) B) (.subst .wk f) (.bvar 0))) | ⟨_, hΓ, _, _, hF, _, hf, ftp⟩ => by obtain ⟨_, _, hA, _, hB, eq⟩ := I.mem_ofType_pi.1 hF; simp at eq; subst eq - refine - have sB := (I.mem_ofType_ofTerm_subst _ (.up (.wk _ _) _ _ _ rfl) (CSb.up_toSb _)).1 hB - have hv := I.ofTerm_bvar ▸ CObj.mem_var_zero.2 ⟨rfl, by simp⟩ - have hl := I.mem_ofTerm_lam.2 ⟨rfl, _, hA, _, - I.mem_ofTerm_app.2 ⟨_, _, I.mem_ofTerm_wk _ hf, _, hv, _, by simp, _, sB, ?_, rfl⟩, - (s.etaExpand_eq (f_tp := ftp) ..).symm⟩ - ⟨_, hΓ, _, _, hF, _, hf, hl, ftp⟩ - simp [ftp, comp_mkPi] + -- refine + -- have sB := (I.mem_ofType_ofTerm_subst _ (.up (.wk _ _) _ _ _ rfl) (CSb.up_toSb _)).1 hB + -- have hv := I.ofTerm_bvar ▸ CObj.mem_var_zero.2 ⟨rfl, by simp⟩ + -- have hl := I.mem_ofTerm_lam.2 ⟨rfl, _, hA, _, + -- I.mem_ofTerm_app.2 ⟨_, _, I.mem_ofTerm_wk _ hf, _, hv, _, by simp, _, sB, ?_, rfl⟩, + -- (s.etaExpand_eq (f_tp := ftp) ..).symm⟩ + -- ⟨_, hΓ, _, _, hF, _, hf, hl, ftp⟩ + -- simp [ftp, comp_mkPi] + sorry theorem EqTmIH.pair_fst_snd {Γ A B p l l'} : I.WfTmIH Γ (max l l') (Expr.sigma l l' A B) p → @@ -1337,4 +1340,4 @@ def snoc [DecidableEq χ] (I : Interpretation χ s) (c : χ) (l : Nat) (l_lt : l ax d k _ := if h : c = d ∧ k = l then some (h.2 ▸ sc) else I.ax d k end Interpretation -end StructuredModel.Universe +end StructuredUniverse diff --git a/HoTTLean/Model/StructuredModel.lean b/HoTTLean/Model/StructuredModel.lean index 75508b24..d321eb10 100644 --- a/HoTTLean/Model/StructuredModel.lean +++ b/HoTTLean/Model/StructuredModel.lean @@ -12,22 +12,20 @@ noncomputable section open CategoryTheory Limits Opposite -namespace StructuredModel +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 Universe {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) - extends UnstructuredModel.Universe Ctx where +structure StructuredUniverse {Ctx : Type u} [Category Ctx] (R : MorphismProperty Ctx) + extends UnstructuredUniverse Ctx where morphismProperty : R tp --- FIXME: rename `Universe.toUniverse` to `Univese.toUnstructured` +namespace StructuredUniverse -namespace Universe +open Model.UnstructuredUniverse -open UnstructuredModel.Universe - -variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} (M : Universe R) +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 := by @@ -43,8 +41,8 @@ def pullbackIsoExt {Γ : Ctx} (A : Γ ⟶ M.Ty) : /-! ## Pullback of representable natural transformation -/ /-- Pull a natural model back along a type. -/ -protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : Universe R where - __ := UnstructuredModel.Universe.pullback M.toUniverse A +protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : StructuredUniverse R where + __ := UnstructuredUniverse.pullback M.toUnstructuredUniverse A morphismProperty := R.of_isPullback (disp_pullback ..) M.morphismProperty /-- @@ -66,8 +64,8 @@ protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : Universe R where def ofIsPullback {U E : Ctx} {π : E ⟶ U} {toTy : U ⟶ M.Ty} {toTm : E ⟶ M.Tm} (pb : IsPullback toTm π M.tp toTy) : - Universe R where - __ := UnstructuredModel.Universe.ofIsPullback M.toUniverse pb + StructuredUniverse R where + __ := UnstructuredUniverse.ofIsPullback M.toUnstructuredUniverse pb morphismProperty := R.of_isPullback pb M.morphismProperty /-! ## Polynomial functor on `tp` @@ -149,7 +147,7 @@ theorem snd_comp_left {A} (eqA : fst M AB = A) {σA} (eqσ : σ ≫ A = σA) : convert UvPoly.Equiv.snd'_comp_left AB H1 _ H2 apply H1.hom_ext <;> simp [substWk] -theorem mk_comp_left {Δ Γ : Ctx} (M : Universe R) (σ : Δ ⟶ Γ) +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] @@ -160,7 +158,7 @@ theorem mk_comp_left {Δ Γ : Ctx} (M : Universe R) (σ : Δ ⟶ Γ) · simp · simp [substWk_disp] -theorem mk_comp_right {Γ : Ctx} (M : Universe R) +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 .. @@ -184,15 +182,15 @@ theorem PtpEquiv.mk_map {Γ : Ctx} {X Y : Ctx} /-! ## Polynomial composition `M.tp ▸ N.tp` -/ -abbrev compDom (M N : Universe R) : Ctx := M.uvPolyTp.compDom N.uvPolyTp +abbrev compDom (M N : StructuredUniverse R) : Ctx := M.uvPolyTp.compDom N.uvPolyTp -abbrev compP (M N : Universe R) : M.compDom N ⟶ M.uvPolyTp @ N.Ty := +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 : Universe R} {Γ Δ : Ctx} (σ : Δ ⟶ Γ) +variable {M N : StructuredUniverse R} {Γ Δ : Ctx} (σ : Δ ⟶ Γ) /-- Universal property of `compDom`, decomposition (part 1). @@ -240,7 +238,7 @@ def dependent (ab : Γ ⟶ M.uvPolyTp.compDom N.uvPolyTp) 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 = Universe.PtpEquiv.snd M (ab ≫ M.compP N) A (by simp [← eq, fst_tp]) := by + 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) @@ -353,7 +351,7 @@ end compDomEquiv /-- 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 : Universe R) where +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 @@ -375,7 +373,7 @@ protected abbrev Pi := PolymorphicPi M M M namespace PolymorphicPi -variable {U0 U1 U2 : Universe R} {Γ : Ctx} +variable {U0 U1 U2 : StructuredUniverse R} {Γ : Ctx} section variable (P : PolymorphicPi U0 U1 U2) @@ -552,7 +550,8 @@ theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ U0.Ty) (B : (U0.ext A) ⟶ U1.Ty) assumption def toUnstructured : - UnstructuredModel.Universe.PolymorphicPi U0.toUniverse U1.toUniverse U2.toUniverse where + UnstructuredUniverse.PolymorphicPi U0.toUnstructuredUniverse + U1.toUnstructuredUniverse U2.toUnstructuredUniverse where Pi := P.mkPi _ Pi_comp _ _ _ _ _ := (P.comp_mkPi ..).symm lam _ b _ := P.mkLam _ b @@ -568,8 +567,9 @@ end namespace ofUnstructured -variable {U0 U1 U2 : Universe R} - (P : UnstructuredModel.Universe.PolymorphicPi U0.toUniverse U1.toUniverse U2.toUniverse) +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) @@ -629,8 +629,8 @@ lemma lift_uniq (f : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) end ofUnstructured -def ofUnstructured (P : UnstructuredModel.Universe.PolymorphicPi U0.toUniverse U1.toUniverse - U2.toUniverse) : PolymorphicPi U0 U1 U2 where +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) @@ -645,7 +645,7 @@ end PolymorphicPi /-- 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 : Universe R) where +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 @@ -666,7 +666,7 @@ protected abbrev Sigma := PolymorphicSigma M M M namespace PolymorphicSigma -variable {U0 U1 U2 : Universe R} {Γ : Ctx} +variable {U0 U1 U2 : StructuredUniverse R} {Γ : Ctx} section variable (S : PolymorphicSigma U0 U1 U2) @@ -801,8 +801,9 @@ end namespace ofUnstructured -variable {U0 U1 U2 : Universe R} - (S : UnstructuredModel.Universe.PolymorphicSigma U0.toUniverse U1.toUniverse U2.toUniverse) +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) @@ -902,8 +903,9 @@ lemma lift_uniq (ab : Γ ⟶ U2.Tm) (AB : Γ ⟶ U0.uvPolyTp @ U1.Ty) end ofUnstructured -def ofUnstructured {U0 U1 U2 : Universe R} - (S : UnstructuredModel.Universe.PolymorphicSigma U0.toUniverse U1.toUniverse U2.toUniverse) : +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 @@ -1061,7 +1063,7 @@ 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 : Universe 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,7 +1081,7 @@ protected structure Id' (i : IdIntro M) (N : Universe R) where namespace Id' -variable {M} {N : Universe R} {ii : M.IdIntro} (i : M.Id' ii N) {Γ : Ctx} (a : Γ ⟶ M.Tm) +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) @@ -1207,7 +1209,7 @@ def verticalNatTrans : ie.iFunctor ⟶ (UvPoly.id R M.Tm).functor := section reflCase -variable (i : IdIntro M) {N : Universe R} +variable (i : IdIntro M) {N : StructuredUniverse R} variable {Γ : Ctx} (a : Γ ⟶ M.Tm) (r : Γ ⟶ N.Tm) @@ -1439,7 +1441,7 @@ 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 : Universe R) where +structure Id {ii : IdIntro M} (ie : IdElimBase ii) (N : StructuredUniverse R) where weakPullback : WeakPullback (ie.verticalNatTrans.app N.Tm) (ie.iFunctor.map N.tp) @@ -1448,7 +1450,7 @@ structure Id {ii : IdIntro M} (ie : IdElimBase ii) (N : Universe R) where namespace Id -variable {N : Universe R} {ii : IdIntro M} {ie : IdElimBase ii} (i : Id ie N) +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) diff --git a/HoTTLean/Model/UHom.lean b/HoTTLean/Model/UHom.lean index 2b9f2a7b..e10d0416 100644 --- a/HoTTLean/Model/UHom.lean +++ b/HoTTLean/Model/UHom.lean @@ -11,14 +11,14 @@ noncomputable section open CategoryTheory Limits Opposite MonoidalCategory -namespace StructuredModel +namespace Model -namespace Universe +namespace StructuredUniverse -open UnstructuredModel.Universe +open UnstructuredUniverse variable {Ctx : Type u} [Category Ctx] {R : MorphismProperty Ctx} - (M : StructuredModel.Universe R) + (M : StructuredUniverse R) variable [ChosenTerminal Ctx] [R.HasObjects] [R.IsMultiplicative] [R.HasPullbacks] [R.IsStableUnderBaseChange] @@ -28,28 +28,28 @@ open ChosenTerminal macro "by>" s:tacticSeq : term => `(by as_aux_lemma => $s) -structure Hom (M N : Universe R) where +structure Hom (M N : StructuredUniverse R) where mapTm : M.Tm ⟶ N.Tm mapTy : M.Ty ⟶ N.Ty pb : IsPullback mapTm M.tp N.tp mapTy -def Hom.id (M : Universe R) : Hom M M where +def Hom.id (M : StructuredUniverse R) : Hom M M where mapTm := 𝟙 _ mapTy := 𝟙 _ pb := IsPullback.of_id_fst -def Hom.comp {M N O : Universe R} (α : Hom M N) (β : Hom N O) : Hom M O where +def Hom.comp {M N O : StructuredUniverse R} (α : Hom M N) (β : Hom N O) : Hom M O where mapTm := α.mapTm ≫ β.mapTm mapTy := α.mapTy ≫ β.mapTy pb := α.pb.paste_horiz β.pb -def Hom.comp_assoc {M N O P : Universe R} (α : Hom M N) (β : Hom N O) (γ : Hom O P) : +def Hom.comp_assoc {M N O P : StructuredUniverse R} (α : Hom M N) (β : Hom N O) (γ : Hom O P) : comp (comp α β) γ = comp α (comp β γ) := by simp [comp] /-- Morphism into the representable natural transformation `M` from the pullback of `M` along a type. -/ -protected def pullbackHom (M : Universe R) {Γ : Ctx} (A : (Γ) ⟶ M.Ty) : +protected def pullbackHom (M : StructuredUniverse R) {Γ : Ctx} (A : (Γ) ⟶ M.Ty) : Hom (M.pullback A) M where mapTm := M.var A mapTy := A @@ -58,7 +58,7 @@ protected def pullbackHom (M : Universe R) {Γ : Ctx} (A : (Γ) ⟶ M.Ty) : /-- Given `M : Universe`, a semantic type `A : (Γ) ⟶ M.Ty`, and a substitution `σ : Δ ⟶ Γ`, construct a Hom for the substitution `A[σ]`. -/ -def Hom.subst (M : Universe R) +def Hom.subst (M : StructuredUniverse R) {Γ Δ : Ctx} (A : (Γ) ⟶ M.Ty) (σ : Δ ⟶ Γ) : Hom (M.pullback ((σ) ≫ A)) (M.pullback A) := let Aσ := (σ) ≫ A @@ -68,7 +68,7 @@ def Hom.subst (M : Universe R) pb := by convert IsPullback.of_right' (M.disp_pullback Aσ) (M.disp_pullback A)} -@[simp] def Hom.extIsoExt {M N : Universe R} (h : Hom M N) +@[simp] def Hom.extIsoExt {M N : StructuredUniverse R} (h : Hom M N) {Γ} (A : Γ ⟶ M.Ty) : (N.ext (A ≫ h.mapTy)) ≅ (M.ext A) := IsPullback.isoIsPullback N.Tm Γ (N.disp_pullback (A ≫ h.mapTy)) (IsPullback.paste_horiz (M.disp_pullback A) h.pb) @@ -80,7 +80,7 @@ These don't form a category since `UHom.id M` is essentially `Type : Type` in `M Note this doesn't need to extend `Hom` as none of its fields are used; it's just convenient to pack up the data. -/ -structure UHom (M N : Universe R) extends Hom M N where +structure UHom (M N : StructuredUniverse R) extends Hom M N where U : ChosenTerminal.terminal ⟶ N.Ty asTm : M.Ty ⟶ N.Tm U_pb : IsPullback @@ -89,7 +89,7 @@ structure UHom (M N : Universe R) extends Hom M N where /- ⊤ -/ U /- N.Ty -/ def UHom.ofTyIsoExt - {M N : Universe R} + {M N : StructuredUniverse R} (H : Hom M N) {U : (𝟭_ Ctx) ⟶ N.Ty} (i : M.Ty ≅ (N.ext U)) : UHom M N where __ := H @@ -99,27 +99,27 @@ def UHom.ofTyIsoExt convert IsPullback.of_iso_isPullback (N.disp_pullback _) i apply ChosenTerminal.isTerminal.hom_ext -def UHom.comp {M N O : Universe R} (α : UHom M N) (β : UHom N O) : UHom M O where +def UHom.comp {M N O : StructuredUniverse R} (α : UHom M N) (β : UHom N O) : UHom M O where __ := Hom.comp α.toHom β.toHom U := α.U ≫ β.mapTy asTm := α.asTm ≫ β.mapTm U_pb := α.U_pb.paste_horiz β.pb -def UHom.comp_assoc {M N O P : Universe R} (α : UHom M N) (β : UHom N O) (γ : UHom O P) : +def UHom.comp_assoc {M N O P : StructuredUniverse R} (α : UHom M N) (β : UHom N O) (γ : UHom O P) : comp (comp α β) γ = comp α (comp β γ) := by simp [comp, Hom.comp] -def UHom.wkU {M N : Universe R} (Γ : Ctx) (α : UHom M N) : (Γ) ⟶ N.Ty := +def UHom.wkU {M N : StructuredUniverse R} (Γ : Ctx) (α : UHom M N) : (Γ) ⟶ N.Ty := ChosenTerminal.isTerminal.from Γ ≫ α.U @[reassoc (attr := simp)] -theorem UHom.comp_wkU {M N : Universe R} {Δ Γ : Ctx} (α : UHom M N) (f : (Δ) ⟶ (Γ)) : +theorem UHom.comp_wkU {M N : StructuredUniverse R} {Δ Γ : Ctx} (α : UHom M N) (f : (Δ) ⟶ (Γ)) : f ≫ α.wkU Γ = α.wkU Δ := by simp [wkU] /- Sanity check: construct a `UHom` into a natural model with a Tarski universe. -/ -def UHom.ofTarskiU (M : Universe R) (U : (𝟭_ Ctx) ⟶ M.Ty) (El : (M.ext U) ⟶ M.Ty) : +def UHom.ofTarskiU (M : StructuredUniverse R) (U : (𝟭_ Ctx) ⟶ M.Ty) (El : (M.ext U) ⟶ M.Ty) : UHom (M.pullback El) M where __ := M.pullbackHom El U @@ -140,14 +140,14 @@ structure UHomSeq where /-- Number of embeddings in the sequence, or one less than the number of models in the sequence. -/ length : Nat - objs (i : Nat) (h : i < length + 1) : Universe R + objs (i : Nat) (h : i < length + 1) : StructuredUniverse R homSucc' (i : Nat) (h : i < length) : UHom (objs i <| by omega) (objs (i + 1) <| by omega) namespace UHomSeq variable (s : UHomSeq R) -instance : GetElem (UHomSeq R) Nat (Universe R) (fun s i => i < s.length + 1) where +instance : GetElem (UHomSeq R) Nat (StructuredUniverse R) (fun s i => i < s.length + 1) where getElem s i h := s.objs i h def homSucc (i : Nat) (h : i < s.length := by get_elem_tactic) : UHom s[i] s[i+1] := @@ -286,12 +286,12 @@ lemma code_el (s : UHomSeq R) {Γ : Ctx} {i : Nat} (ilen : i < s.length) end UHomSeq -def Hom.cartesianNatTrans {M N : StructuredModel.Universe R} (h : Hom M N) : +def Hom.cartesianNatTrans {M N : StructuredUniverse R} (h : Hom M N) : M.Ptp ⟶ N.Ptp := M.uvPolyTp.cartesianNatTrans N.uvPolyTp h.mapTy h.mapTm h.pb @[reassoc] -theorem Hom.mk_comp_cartesianNatTrans {M N : StructuredModel.Universe R} +theorem Hom.mk_comp_cartesianNatTrans {M N : StructuredUniverse R} (h : Hom M N) {Γ X} (A : Γ ⟶ M.Ty) (B : M.ext A ⟶ X) : PtpEquiv.mk M A B ≫ h.cartesianNatTrans.app X = PtpEquiv.mk N (A ≫ h.mapTy) ((h.extIsoExt A).hom ≫ B) := by sorry @@ -429,7 +429,7 @@ can be extended to Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ΠA. B type ``` -/ protected class PiSeq (s : UHomSeq R) where - nmPi (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : Universe.Pi s[i] + nmPi (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : StructuredUniverse.Pi s[i] section Pi open PiSeq @@ -458,176 +458,184 @@ def Pi_pb : sorry -- apply CategoryTheory.IsPullback.paste_horiz (p1.isCartesian s[j].tp).flip q -/-- -``` -Γ ⊢ᵢ A Γ.A ⊢ⱼ B ------------------ -Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ΠA. B -``` -/ -def mkPi {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : (Γ) ⟶ s[max i j].Ty := - PtpEquiv.mk s[i] A B ≫ s.Pi ilen jlen +def polymorphicPi : PolymorphicPi s[i] s[j] s[max i j] where + Pi := Pi s ilen jlen + lam := lam s ilen jlen + Pi_pullback := Pi_pb s ilen jlen -theorem comp_mkPi {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) - (B : (s[i].ext A) ⟶ s[j].Ty) : - (σ) ≫ s.mkPi ilen jlen A B = s.mkPi ilen jlen σA ((s[i].substWk σ A _ eq) ≫ B) := by - simp [mkPi, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] +-- NOTE: the commented out lemmas `lemma_name` are now called +-- from (s.polymorphicPi ilen jlen).name -/-- -``` -Γ ⊢ᵢ A Γ.A ⊢ⱼ t : B -------------------------- -Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ λA. t : ΠA. B -``` -/ -def mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (t : (s[i].ext A) ⟶ s[j].Tm) : (Γ) ⟶ s[max i j].Tm := - PtpEquiv.mk s[i] A t ≫ s.lam ilen jlen +-- /-- +-- ``` +-- Γ ⊢ᵢ A Γ.A ⊢ⱼ B +-- ----------------- +-- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ ΠA. B +-- ``` -/ +-- def mkPi {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) : (Γ) ⟶ s[max i j].Ty := +-- PtpEquiv.mk s[i] A B ≫ s.Pi ilen jlen -@[simp] -theorem mkLam_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (t : (s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) : - s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B := by - simp [mkLam, mkPi, (s.Pi_pb ilen jlen).w, PtpEquiv.mk_map_assoc, t_tp] +-- theorem comp_mkPi {Δ Γ : Ctx} (σ : Δ ⟶ Γ) +-- (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) +-- (B : (s[i].ext A) ⟶ s[j].Ty) : +-- (σ) ≫ s.mkPi ilen jlen A B = s.mkPi ilen jlen σA ((s[i].substWk σ A _ eq) ≫ B) := by +-- simp [mkPi, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] -theorem comp_mkLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) (t : (s[i].ext A) ⟶ s[j].Tm) : - (σ) ≫ s.mkLam ilen jlen A t = s.mkLam ilen jlen σA ((s[i].substWk σ A _ eq) ≫ t) := by - simp [mkLam, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] +-- /-- +-- ``` +-- Γ ⊢ᵢ A Γ.A ⊢ⱼ t : B +-- ------------------------- +-- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ λA. t : ΠA. B +-- ``` -/ +-- def mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (t : (s[i].ext A) ⟶ s[j].Tm) : (Γ) ⟶ s[max i j].Tm := +-- PtpEquiv.mk s[i] A t ≫ s.lam ilen jlen +-- @[simp] +-- theorem mkLam_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (t : (s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) : +-- s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B := by +-- simp [mkLam, mkPi, (s.Pi_pb ilen jlen).w, PtpEquiv.mk_map_assoc, t_tp] -/-- -``` -Γ ⊢ᵢ A Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ f : ΠA. B ------------------------------ -Γ.A ⊢ⱼ unlam f : B -``` -/ -def unLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - (s[i].ext A) ⟶ s[j].Tm := by - let total : (Γ) ⟶ s[i].Ptp.obj s[j].Tm := - (s.Pi_pb ilen jlen).lift f (PtpEquiv.mk s[i] A B) f_tp - refine PtpEquiv.snd s[i] total _ ?_ - have eq : total ≫ s[i].Ptp.map s[j].tp = PtpEquiv.mk s[i] A B := - (s.Pi_pb ilen jlen).lift_snd .. - apply_fun PtpEquiv.fst s[i] at eq - rw [PtpEquiv.fst_comp_right] at eq - simpa using eq +-- theorem comp_mkLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) +-- (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) (t : (s[i].ext A) ⟶ s[j].Tm) : +-- (σ) ≫ s.mkLam ilen jlen A t = s.mkLam ilen jlen σA ((s[i].substWk σ A _ eq) ≫ t) := by +-- simp [mkLam, ← Category.assoc, PtpEquiv.mk_comp_left (eq := eq)] -@[simp] -theorem unLam_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - s.unLam ilen jlen A B f f_tp ≫ s[j].tp = B := by - rw [unLam, ← PtpEquiv.snd_comp_right] - convert PtpEquiv.snd_mk s[i] A B using 2; simp - -theorem comp_unLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - (s[i].substWk σ A _ eq) ≫ s.unLam ilen jlen A B f f_tp = - s.unLam ilen jlen σA ((s[i].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 (s.Pi_pb ilen jlen).hom_ext <;> simp - rw [PtpEquiv.mk_comp_left] -/-- -``` -Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ f : ΠA. B Γ ⊢ᵢ a : A ---------------------------------- -Γ ⊢ⱼ f a : B[id.a] -``` -/ -def mkApp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : (Γ) ⟶ s[j].Tm := - (s[i].sec A a a_tp) ≫ s.unLam ilen jlen A B f f_tp +-- /-- +-- ``` +-- Γ ⊢ᵢ A Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ f : ΠA. B +-- ----------------------------- +-- Γ.A ⊢ⱼ unlam f : B +-- ``` -/ +-- def unLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +-- (s[i].ext A) ⟶ s[j].Tm := by +-- let total : (Γ) ⟶ s[i].Ptp.obj s[j].Tm := +-- (s.Pi_pb ilen jlen).lift f (PtpEquiv.mk s[i] A B) f_tp +-- refine PtpEquiv.snd s[i] total _ ?_ +-- have eq : total ≫ s[i].Ptp.map s[j].tp = PtpEquiv.mk s[i] A B := +-- (s.Pi_pb ilen jlen).lift_snd .. +-- apply_fun PtpEquiv.fst s[i] at eq +-- rw [PtpEquiv.fst_comp_right] at eq +-- simpa using eq -@[simp] -theorem mkApp_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : - s.mkApp ilen jlen A B f f_tp a a_tp ≫ s[j].tp = (s[i].sec A a a_tp) ≫ B := by - simp [mkApp] - -theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) - (A : Γ ⟶ s[i].Ty) (σA) (eq : σ ≫ A = σA) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : Γ ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : - σ ≫ s.mkApp ilen jlen A B f f_tp a a_tp = - s.mkApp ilen jlen σA (s[i].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 unLam_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +-- s.unLam ilen jlen A B f f_tp ≫ s[j].tp = B := by +-- rw [unLam, ← PtpEquiv.snd_comp_right] +-- convert PtpEquiv.snd_mk s[i] A B using 2; simp + +-- theorem comp_unLam {Δ Γ : Ctx} (σ : Δ ⟶ Γ) +-- (A : (Γ) ⟶ s[i].Ty) (σA) (eq : (σ) ≫ A = σA) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +-- (s[i].substWk σ A _ eq) ≫ s.unLam ilen jlen A B f f_tp = +-- s.unLam ilen jlen σA ((s[i].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 (s.Pi_pb ilen jlen).hom_ext <;> simp +-- rw [PtpEquiv.mk_comp_left] -@[simp] -theorem mkLam_unLam {Γ : Ctx} (A : Γ ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - s.mkLam ilen jlen A (s.unLam ilen jlen A B f f_tp) = f := by - let total : Γ ⟶ s[i].Ptp.obj s[j].Tm := - (s.Pi_pb ilen jlen).lift f (PtpEquiv.mk s[i] A B) f_tp - simp only [mkLam, unLam] - have : PtpEquiv.fst s[i] total = A := by - simp only [PtpEquiv.fst, UvPoly.Equiv.fst_eq, total] - rw [← s[i].uvPolyTp.map_fstProj s[j].tp] - slice_lhs 1 2 => apply (s.Pi_pb ilen jlen).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 (s.Pi_pb ilen jlen).lift_fst +-- /-- +-- ``` +-- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ f : ΠA. B Γ ⊢ᵢ a : A +-- --------------------------------- +-- Γ ⊢ⱼ f a : B[id.a] +-- ``` -/ +-- def mkApp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) +-- (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : (Γ) ⟶ s[j].Tm := +-- (s[i].sec A a a_tp) ≫ s.unLam ilen jlen A B f f_tp -@[simp] -theorem unLam_mkLam {Γ : Ctx} (A : Γ ⟶ s[i].Ty) (B : s[i].ext A ⟶ s[j].Ty) - (t : s[i].ext A ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) - (lam_tp : s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - s.unLam ilen jlen A B (s.mkLam ilen jlen A t) lam_tp = t := by - simp [mkLam, unLam] - convert PtpEquiv.snd_mk s[i] A t using 2 - apply (s.Pi_pb ilen jlen).hom_ext <;> simp - rw [PtpEquiv.mk_comp_right, t_tp] +-- @[simp] +-- theorem mkApp_tp {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) +-- (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : +-- s.mkApp ilen jlen A B f f_tp a a_tp ≫ s[j].tp = (s[i].sec A a a_tp) ≫ B := by +-- simp [mkApp] + +-- theorem comp_mkApp {Δ Γ : Ctx} (σ : Δ ⟶ Γ) +-- (A : Γ ⟶ s[i].Ty) (σA) (eq : σ ≫ A = σA) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) +-- (a : Γ ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : +-- σ ≫ s.mkApp ilen jlen A B f f_tp a a_tp = +-- s.mkApp ilen jlen σA (s[i].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)] -/-- -``` -Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ f : ΠA. B --------------------------------------- -Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ λA. f[↑] v₀ : ΠA. B -``` --/ -def etaExpand {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - (Γ) ⟶ s[max i j].Tm := - s.mkLam ilen jlen A <| - s.mkApp ilen jlen - (s[i].disp A ≫ A) (s[i].substWk .. ≫ B) (s[i].disp A ≫ f) - (by simp [f_tp, comp_mkPi]) - (s[i].var A) (s[i].var_tp A) - -theorem etaExpand_eq {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : - s.etaExpand ilen jlen A B f f_tp = f := by - simp [etaExpand] - convert s.mkLam_unLam ilen jlen A B f f_tp using 2 - simp [mkApp]; rw [← comp_unLam (f_tp := f_tp), ← Category.assoc] - conv_rhs => rw [← Category.id_comp (s.unLam ..)] - congr 2 - apply (s[i].disp_pullback A).hom_ext <;> simp - simp [substWk] +-- @[simp] +-- theorem mkLam_unLam {Γ : Ctx} (A : Γ ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +-- s.mkLam ilen jlen A (s.unLam ilen jlen A B f f_tp) = f := by +-- let total : Γ ⟶ s[i].Ptp.obj s[j].Tm := +-- (s.Pi_pb ilen jlen).lift f (PtpEquiv.mk s[i] A B) f_tp +-- simp only [mkLam, unLam] +-- have : PtpEquiv.fst s[i] total = A := by +-- simp only [PtpEquiv.fst, UvPoly.Equiv.fst_eq, total] +-- rw [← s[i].uvPolyTp.map_fstProj s[j].tp] +-- slice_lhs 1 2 => apply (s.Pi_pb ilen jlen).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 (s.Pi_pb ilen jlen).lift_fst -/-- -``` -Γ ⊢ᵢ A Γ.A ⊢ⱼ t : B Γ ⊢ᵢ a : A --------------------------------- -Γ.A ⊢ⱼ (λA. t) a ≡ t[a] : B[a] -``` -/ -@[simp] -theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) - (t : (s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) - (lam_tp : s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B) - (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : - s.mkApp ilen jlen A B (s.mkLam ilen jlen A t) lam_tp a a_tp = (s[i].sec A a a_tp) ≫ t := by - rw [mkApp, unLam_mkLam] - assumption +-- @[simp] +-- theorem unLam_mkLam {Γ : Ctx} (A : Γ ⟶ s[i].Ty) (B : s[i].ext A ⟶ s[j].Ty) +-- (t : s[i].ext A ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) +-- (lam_tp : s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +-- s.unLam ilen jlen A B (s.mkLam ilen jlen A t) lam_tp = t := by +-- simp [mkLam, unLam] +-- convert PtpEquiv.snd_mk s[i] A t using 2 +-- apply (s.Pi_pb ilen jlen).hom_ext <;> simp +-- rw [PtpEquiv.mk_comp_right, t_tp] + +-- /-- +-- ``` +-- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ f : ΠA. B +-- -------------------------------------- +-- Γ ⊢ₘₐₓ₍ᵢ,ⱼ₎ λA. f[↑] v₀ : ΠA. B +-- ``` +-- -/ +-- def etaExpand {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : Γ ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +-- (Γ) ⟶ s[max i j].Tm := +-- s.mkLam ilen jlen A <| +-- s.mkApp ilen jlen +-- (s[i].disp A ≫ A) (s[i].substWk .. ≫ B) (s[i].disp A ≫ f) +-- (by simp [f_tp, comp_mkPi]) +-- (s[i].var A) (s[i].var_tp A) + +-- theorem etaExpand_eq {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (f : (Γ) ⟶ s[max i j].Tm) (f_tp : f ≫ s[max i j].tp = s.mkPi ilen jlen A B) : +-- s.etaExpand ilen jlen A B f f_tp = f := by +-- simp [etaExpand] +-- convert s.mkLam_unLam ilen jlen A B f f_tp using 2 +-- simp [mkApp]; rw [← comp_unLam (f_tp := f_tp), ← Category.assoc] +-- conv_rhs => rw [← Category.id_comp (s.unLam ..)] +-- congr 2 +-- apply (s[i].disp_pullback A).hom_ext <;> simp +-- simp [substWk] + +-- /-- +-- ``` +-- Γ ⊢ᵢ A Γ.A ⊢ⱼ t : B Γ ⊢ᵢ a : A +-- -------------------------------- +-- Γ.A ⊢ⱼ (λA. t) a ≡ t[a] : B[a] +-- ``` -/ +-- @[simp] +-- theorem mkApp_mkLam {Γ : Ctx} (A : (Γ) ⟶ s[i].Ty) (B : (s[i].ext A) ⟶ s[j].Ty) +-- (t : (s[i].ext A) ⟶ s[j].Tm) (t_tp : t ≫ s[j].tp = B) +-- (lam_tp : s.mkLam ilen jlen A t ≫ s[max i j].tp = s.mkPi ilen jlen A B) +-- (a : (Γ) ⟶ s[i].Tm) (a_tp : a ≫ s[i].tp = A) : +-- s.mkApp ilen jlen A B (s.mkLam ilen jlen A t) lam_tp a a_tp = (s[i].sec A a a_tp) ≫ t := by +-- rw [mkApp, unLam_mkLam] +-- assumption end Pi @@ -635,7 +643,7 @@ end Pi /-- The data of `Sig` and `pair` formers at each universe `s[i].tp`. -/ class SigSeq (s : UHomSeq R) where - nmSig (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : Universe.Sigma s[i] + nmSig (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : StructuredUniverse.Sigma s[i] section Sigma open SigSeq @@ -804,11 +812,11 @@ def polymorphicSigma : PolymorphicSigma s[i] s[j] s[max i j] where /-! ## Identity types -/ class IdSeq (s : UHomSeq R) where - nmII (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : Universe.IdIntro s[i] + nmII (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : IdIntro s[i] nmIEB (i : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) : - Universe.IdElimBase (nmII i ilen) + IdElimBase (nmII i ilen) nmId (i j : Nat) (ilen : i < s.length + 1 := by get_elem_tactic) - (jlen : j < s.length + 1 := by get_elem_tactic) : Universe.Id (nmIEB i ilen) s[j] + (jlen : j < s.length + 1 := by get_elem_tactic) : Id (nmIEB i ilen) s[j] section Id open IdSeq diff --git a/HoTTLean/Model/UnstructuredModel.lean b/HoTTLean/Model/UnstructuredModel.lean index dc21da8a..0eb90b9d 100644 --- a/HoTTLean/Model/UnstructuredModel.lean +++ b/HoTTLean/Model/UnstructuredModel.lean @@ -10,12 +10,12 @@ noncomputable section open CategoryTheory Limits Opposite -namespace UnstructuredModel +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 Universe (Ctx : Type u) [Category Ctx] where +structure UnstructuredUniverse (Ctx : Type u) [Category Ctx] where Tm : Ctx Ty : Ctx tp : Tm ⟶ Ty @@ -25,14 +25,14 @@ structure Universe (Ctx : Type u) [Category Ctx] where disp_pullback {Γ : Ctx} (A : Γ ⟶ Ty) : IsPullback (var A) (disp A) tp A -namespace Universe +namespace UnstructuredUniverse -variable {Ctx : Type u} [Category Ctx] (M : Universe Ctx) +variable {Ctx : Type u} [Category Ctx] (M : UnstructuredUniverse Ctx) /-! ## Pullback of representable natural transformation -/ /-- Pull a natural model back along a type. -/ -protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : Universe Ctx where +protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : UnstructuredUniverse Ctx where Tm := M.ext A Ty := Γ tp := M.disp A @@ -62,7 +62,7 @@ protected def pullback {Γ : Ctx} (A : Γ ⟶ M.Ty) : Universe Ctx where def ofIsPullback {U E : Ctx} {π : E ⟶ U} {toTy : U ⟶ M.Ty} {toTm : E ⟶ M.Tm} (pb : IsPullback toTm π M.tp toTy) : - Universe Ctx where + UnstructuredUniverse Ctx where Ty := U Tm := E tp := π @@ -198,7 +198,7 @@ theorem comp_sec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (σA) (eq : σ apply (M.disp_pullback _).hom_ext <;> simp [sec, substWk] -structure PolymorphicSigma (U0 U1 U2 : Universe Ctx) where +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) @@ -238,7 +238,7 @@ structure PolymorphicSigma (U0 U1 U2 : Universe Ctx) where (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) -structure PolymorphicPi (U0 U1 U2 : Universe Ctx) where +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) @@ -264,6 +264,6 @@ structure PolymorphicPi (U0 U1 U2 : Universe Ctx) where (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) -end Universe +end UnstructuredUniverse -end UnstructuredModel +end Model diff --git a/HoTTLean/Groupoids/SigmaBackup.lean b/attic/SigmaBackup.lean similarity index 100% rename from HoTTLean/Groupoids/SigmaBackup.lean rename to attic/SigmaBackup.lean From 4735586aaa65ccacc6b23e86a909f9853a179769 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 3 Oct 2025 16:57:35 -0400 Subject: [PATCH 20/59] feat: use MvPoly cartesianNatTrans proof to prove UvPoly result --- HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean index 6f281851..0f4e1314 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Polynomial.lean @@ -959,16 +959,17 @@ C --- > C/E -----> C/B -----> C -/ 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 ..) + 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 := - -- (isCartesian_of_isIso _).vComp <| - -- (isCartesian_of_isIso _).vComp <| - -- isCartesian_pullbackForgetTwoSquare _ - sorry + (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 From a03bb09e8caeb95998a276039911abd83b03af3a Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 3 Oct 2025 20:34:40 -0400 Subject: [PATCH 21/59] remove dead files --- HoTTLean/Groupoids/Id.lean | 2 -- HoTTLean/Groupoids/NaturalModelBase.lean | 0 HoTTLean/Model/NaturalModel.lean | 0 3 files changed, 2 deletions(-) delete mode 100644 HoTTLean/Groupoids/NaturalModelBase.lean delete mode 100644 HoTTLean/Model/NaturalModel.lean diff --git a/HoTTLean/Groupoids/Id.lean b/HoTTLean/Groupoids/Id.lean index 9a13ca49..48f89cbd 100644 --- a/HoTTLean/Groupoids/Id.lean +++ b/HoTTLean/Groupoids/Id.lean @@ -1,7 +1,5 @@ import HoTTLean.Groupoids.UnstructuredModel -import HoTTLean.Model.NaturalModel - import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone universe w v u v₁ u₁ v₂ u₂ diff --git a/HoTTLean/Groupoids/NaturalModelBase.lean b/HoTTLean/Groupoids/NaturalModelBase.lean deleted file mode 100644 index e69de29b..00000000 diff --git a/HoTTLean/Model/NaturalModel.lean b/HoTTLean/Model/NaturalModel.lean deleted file mode 100644 index e69de29b..00000000 From 95392a41d80ddcde34c6c1576300b7b5ab1b40de Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 3 Oct 2025 23:21:49 -0400 Subject: [PATCH 22/59] feat: isofibration homEquiv --- HoTTLean/Groupoids/IsIsofibration.lean | 127 +++++++++++++++++++++---- 1 file changed, 106 insertions(+), 21 deletions(-) diff --git a/HoTTLean/Groupoids/IsIsofibration.lean b/HoTTLean/Groupoids/IsIsofibration.lean index aed03597..1c8fa00f 100644 --- a/HoTTLean/Groupoids/IsIsofibration.lean +++ b/HoTTLean/Groupoids/IsIsofibration.lean @@ -46,6 +46,22 @@ lemma equivInv_comp_forget (G : ∫ σ ⋙ A ⥤ ∫ B) (hG : G ⋙ forget = pre 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] + -- TODO: work out naturality equations for this bijection end GroupoidModel.FunctorOperation.pi @@ -112,10 +128,18 @@ def isofibration {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : F.Isofibra /-- The Grothendieck construction on the classifier is isomorphic to `E`, now as objects in `Grpd`. -/ -def grothendieckClassifierIso {E Γ : Grpd} {F : E ⟶ Γ} (hF : IsIsofibration F) : - Grpd.of (∫ hF.isofibration.classifier) ≅ E := +def grothendieckClassifierIso {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : + Grpd.of (∫ hF.isofibration.classifier) ≅ B := Grpd.mkIso (Functor.Isofibration.grothendieckClassifierIso ..) +-- lemma grothendieckClassifierIso_hom_comp_eq_forget {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : +-- hF.grothendieckClassifierIso.hom ⋙ F = homOf Functor.Groupoidal.forget := +-- sorry + +lemma grothendieckClassifierIso_inv_comp_forget {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : + hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := + sorry + end IsIsofibration instance : IsIsofibration.IsStableUnderBaseChange := by @@ -135,12 +159,15 @@ attribute [local instance] Grpd.IsIsofibration.isofibration open Functor.Isofibration -def strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : C ⟶ (Grpd.of <| ∫ classifier (hF.isofibration)) := - sorry +def strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) (G : C ⟶ B) : + C ⟶ Grpd.of (∫ classifier (hF.isofibration)) := + G ≫ hF.grothendieckClassifierIso.inv + +def isIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsIsofibration (strictify hF G) := sorry -lemma isIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : IsIsofibration (strictify hF hG) := sorry +def isofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : (strictify hF G).Isofibration := sorry /-- The object part (a groupoid) of the pushforward along `F`, of `G`, defined as the Grothendieck construction applied to (unstructured) Pi-type construction @@ -148,7 +175,7 @@ in the HoTTLean groupoid model. -/ def pushforwardLeft {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} (hG : IsIsofibration G) : Grpd := Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.isofibration.classifier) - (classifier (isIsofibration_strictify hF hG).isofibration)) + (classifier (isofibration_strictify hF hG))) /-- The morphism part (a functor) of the pushforward along `F`, of `G`. This is defined as the forgetful functor from the Grothendieck construction. -/ @@ -161,24 +188,82 @@ abbrev pushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} (hG : IsIsofibration G) : Over A := Over.mk (pushforwardHom hF hG) --- This is one step towards the equivalence `pushforwardHomEquiv` -def pushforwardHomEquivAux {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) (X : Over A) : - (X ⟶ pushforward hF hG) ≃ - (f : ∫ X.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isIsofibration_strictify hF hG).isofibration.classifier) ×' - (f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier X.hom) where - toFun f := ⟨GroupoidModel.FunctorOperation.pi.equivFun (σ := X.hom) _ f.left f.w, - GroupoidModel.FunctorOperation.pi.equivFun_comp_forget (σ := X.hom) _ f.left f.w⟩ - invFun := sorry +open Limits in +lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : IsIsofibration 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 : IsIsofibration F) (σ : Over A) : + IsPullback (homOf (pre hF.isofibration.classifier σ.hom)) (homOf Functor.Groupoidal.forget) + (homOf Functor.Groupoidal.forget) (homOf σ.hom) := by + have outer_pb := Functor.Groupoidal.isPullback (σ.hom ⋙ hF.isofibration.classifier) + have right_pb := Functor.Groupoidal.isPullback (hF.isofibration.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 pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : IsIsofibration F) (σ : Over A) : + Grpd.of (∫ σ.hom ⋙ hF.isofibration.classifier) ≅ Limits.pullback σ.hom F := + (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) + +open GroupoidModel.FunctorOperation.pi in +/-- `∫ σ.hom ⋙ hF.isofibration.classifier` is the pullback of `F` along `σ`, +`∫ (isofibration_strictify hF hG).classifier` is isomorphic to `G`. +So up to isomorphism this is the hom set bijection we want. -/ +def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ + {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } where + toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ + invFun f := Over.homMk (equivInv _ f.1 f.2) + (equivInv_comp_forget ..) + left_inv f := by + ext + simp [equivInv_equivFun] + right_inv f := by + ext + simp [equivFun_equivInv] + +def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (σ : Over A) : + { f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } ≃ + ((Over.pullback F).obj σ ⟶ Over.mk G) where + toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ + ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry + invFun f := ⟨(pullbackIsoGrothendieck hF σ).hom ≫ f.left ≫ + ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ left_inv := sorry right_inv := sorry +open GroupoidModel.FunctorOperation.pi in /-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) (X : Over A) : - (X ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj X ⟶ Over.mk G) := by - dsimp [pushforward, pushforwardHom] - sorry + (hG : IsIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := + calc (σ ⟶ pushforward hF hG) + _ ≃ {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + (f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom)} := + pushforwardHomEquivAux1 .. + _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. /-- Naturality in the universal property of the pushforward. -/ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} From 8aba26ee50fe4aa1529a19cb10b5827ceda28434 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 5 Oct 2025 08:38:26 -0400 Subject: [PATCH 23/59] confirm we can arrive in pushforward of groupoid isofib --- HoTTLean/Groupoids/IsIsofibration.lean | 61 +++++++++++++++++++++++++- 1 file changed, 59 insertions(+), 2 deletions(-) diff --git a/HoTTLean/Groupoids/IsIsofibration.lean b/HoTTLean/Groupoids/IsIsofibration.lean index 1c8fa00f..3795bcdc 100644 --- a/HoTTLean/Groupoids/IsIsofibration.lean +++ b/HoTTLean/Groupoids/IsIsofibration.lean @@ -92,9 +92,27 @@ instance {X : Γ} : Groupoid (F.Fiber X) := Groupoid.ofIsGroupoid /-- Any isofibration `F : E ⥤ Γ` of groupoids is classified by a functor `classifier : Γ ⥤ Grpd`. -/ + +def classifier.map.obj {X Y} (f: X ⟶ Y) (a:(Grpd.of (F.Fiber X))) : Grpd.of (F.Fiber Y) := + ⟨liftObj hF f a.2, + by + have p : F.IsHomLift f (hF.liftIso f _) := hF.is_hom_lift_hom f (X' := a.1) a.2 + (apply @IsHomLift.codomain_eq (f := f) (φ:= liftIso (X' := a.1) hF f a.2) ) ⟩ + +def classifier.map.map {X Y} (f: X ⟶ Y) {a b:(Grpd.of (F.Fiber X))} (m: a ⟶ b) : + map.obj hF f a ⟶ map.obj hF f b := + sorry + + +def classifier.map {X Y} (f: X ⟶ Y) : (Grpd.of (F.Fiber X) ⟶ Grpd.of (F.Fiber Y)) where + obj := classifier.map.obj hF f + map {a b} m := classifier.map.map hF f m + map_id := sorry + map_comp := sorry + def classifier : Γ ⥤ Grpd.{v,u} where obj X := Grpd.of (F.Fiber X) - map := + map f := have : Isofibration F := hF -- TODO: remove. This is just to ensure variables used sorry -- use lifting of isomorphisms! map_id := sorry @@ -153,6 +171,8 @@ instance : IsIsofibration.IsMultiplicative := by instance : IsIsofibration.HasObjects := by sorry +instance IsIsofibration.RespectsIso : IsIsofibration.RespectsIso := by sorry + section attribute [local instance] Grpd.IsIsofibration.isofibration @@ -188,6 +208,10 @@ abbrev pushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} (hG : IsIsofibration G) : Over A := Over.mk (pushforwardHom hF hG) +lemma pushforward.hom {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : + (pushforward hF hG).hom = pushforwardHom .. := rfl + open Limits in lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : IsIsofibration F) (σ : Over A) : IsPullback (pullback.snd σ.hom F ≫ hF.grothendieckClassifierIso.inv) (pullback.fst σ.hom F) @@ -265,6 +289,8 @@ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ pushforwardHomEquivAux1 .. _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. + + /-- Naturality in the universal property of the pushforward. -/ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} (hG : IsIsofibration G) @@ -273,6 +299,24 @@ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G (Over.pullback F).map f ≫ (pushforwardHomEquiv hF hG X') g := by sorry + +def Grpd.pushforward.IsPushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) := + --Functor.RepresentableBy.ofIso sorry + sorry + + +def IsPushforward.Grpd.pushforward {B A} {F : B ⟶ A} (hF : IsIsofibration F) + (G: Over B) (hG : IsIsofibration G.hom) (G': Over A) + (h: IsPushforward F G G') : G' ≅ Grpd.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 .. + } ) + instance : IsIsofibration.HasPushforwards IsIsofibration := fun F _ G => { has_representation := ⟨pushforward F.2 G.2, ⟨{ @@ -297,5 +341,18 @@ theorem isIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) `MorphismProperty.rlp_isMultiplicative` `MorphismProperty.respectsIso_of_isStableUnderComposition` 3. The chosen pushforward is an isofibration `isIsofibration_pushforward` -/ + instance : IsIsofibration.IsStableUnderPushforward IsIsofibration where - of_isPushforward F G P := sorry + of_isPushforward F G P := by + intro h + have p: (Over.mk P) ≅ Grpd.pushforward (F.snd) (G.snd) := + IsPushforward.Grpd.pushforward F.snd (Over.mk G.fst) G.snd (Over.mk P) h + have i1 : IsIsofibration (pushforwardHom (F.snd) (G.snd)) := by + apply isIsofibration_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 (IsIsofibration.RespectsIso).precomp + assumption From 2c99b93249efd8983444dc3b31df1e041625981e Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 5 Oct 2025 09:25:43 -0400 Subject: [PATCH 24/59] problem on line 104 --- HoTTLean/Groupoids/IsIsofibration.lean | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/HoTTLean/Groupoids/IsIsofibration.lean b/HoTTLean/Groupoids/IsIsofibration.lean index 3795bcdc..7e27b0fd 100644 --- a/HoTTLean/Groupoids/IsIsofibration.lean +++ b/HoTTLean/Groupoids/IsIsofibration.lean @@ -99,8 +99,11 @@ def classifier.map.obj {X Y} (f: X ⟶ Y) (a:(Grpd.of (F.Fiber X))) : Grpd.of ( have p : F.IsHomLift f (hF.liftIso f _) := hF.is_hom_lift_hom f (X' := a.1) a.2 (apply @IsHomLift.codomain_eq (f := f) (φ:= liftIso (X' := a.1) hF f a.2) ) ⟩ -def classifier.map.map {X Y} (f: X ⟶ Y) {a b:(Grpd.of (F.Fiber X))} (m: a ⟶ b) : - map.obj hF f a ⟶ map.obj hF f b := +def classifier.map.map {X Y} (f: X ⟶ Y) {a b: Grpd.of (F.Fiber X)} (m: a ⟶ b) : + map.obj hF f a ⟶ map.obj hF f b := by + --let i1 : a ⟶ liftObj hF f a.2 := liftIso hF f a.2 + let i2 := liftIso hF f b.2 + --let i := m ≫ i2 sorry From 4eed6360997935d8782c095af1eb38e19252d8da Mon Sep 17 00:00:00 2001 From: jlh18 Date: Sun, 5 Oct 2025 09:58:42 -0400 Subject: [PATCH 25/59] suggestions --- HoTTLean/Groupoids/IsIsofibration.lean | 42 ++++++++++++-------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/HoTTLean/Groupoids/IsIsofibration.lean b/HoTTLean/Groupoids/IsIsofibration.lean index 7e27b0fd..014c63ff 100644 --- a/HoTTLean/Groupoids/IsIsofibration.lean +++ b/HoTTLean/Groupoids/IsIsofibration.lean @@ -74,7 +74,7 @@ structure Functor.Isofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Ca (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' - is_hom_lift_hom {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : + isHomLift {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : F.IsHomLift f (liftIso f hX') namespace Functor.Isofibration @@ -93,13 +93,12 @@ instance {X : Γ} : Groupoid (F.Fiber X) := Groupoid.ofIsGroupoid /-- Any isofibration `F : E ⥤ Γ` of groupoids is classified by a functor `classifier : Γ ⥤ Grpd`. -/ -def classifier.map.obj {X Y} (f: X ⟶ Y) (a:(Grpd.of (F.Fiber X))) : Grpd.of (F.Fiber Y) := - ⟨liftObj hF f a.2, - by - have p : F.IsHomLift f (hF.liftIso f _) := hF.is_hom_lift_hom f (X' := a.1) a.2 - (apply @IsHomLift.codomain_eq (f := f) (φ:= liftIso (X' := a.1) hF f a.2) ) ⟩ +def classifier.map.obj {X Y} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := + ⟨liftObj hF f a.2, by + have p : F.IsHomLift f (hF.liftIso f _) := hF.isHomLift f (X' := a.1) a.2 + apply @IsHomLift.codomain_eq (f := f) (φ := liftIso (X' := a.1) hF f a.2) ⟩ -def classifier.map.map {X Y} (f: X ⟶ Y) {a b: Grpd.of (F.Fiber X)} (m: a ⟶ b) : +def classifier.map.map {X Y} (f: X ⟶ Y) {a b: F.Fiber X} (m: a ⟶ b) : map.obj hF f a ⟶ map.obj hF f b := by --let i1 : a ⟶ liftObj hF f a.2 := liftIso hF f a.2 let i2 := liftIso hF f b.2 @@ -174,8 +173,6 @@ instance : IsIsofibration.IsMultiplicative := by instance : IsIsofibration.HasObjects := by sorry -instance IsIsofibration.RespectsIso : IsIsofibration.RespectsIso := by sorry - section attribute [local instance] Grpd.IsIsofibration.isofibration @@ -303,15 +300,18 @@ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G sorry -def Grpd.pushforward.IsPushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) := - --Functor.RepresentableBy.ofIso sorry - sorry +def pushforward_isPushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) where + homEquiv := pushforwardHomEquiv .. + homEquiv_comp f g := pushforwardHomEquiv_comp hF hG f g +instance : IsIsofibration.HasPushforwards IsIsofibration := + fun F _ G => { + has_representation := ⟨pushforward F.2 G.2, ⟨pushforward_isPushforward F.2 G.2⟩⟩ } -def IsPushforward.Grpd.pushforward {B A} {F : B ⟶ A} (hF : IsIsofibration F) +def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : IsIsofibration F) (G: Over B) (hG : IsIsofibration G.hom) (G': Over A) - (h: IsPushforward F G G') : G' ≅ Grpd.pushforward hF hG := + (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) @@ -320,12 +320,6 @@ def IsPushforward.Grpd.pushforward {B A} {F : B ⟶ A} (hF : IsIsofibration F) homEquiv_comp f g := by apply pushforwardHomEquiv_comp .. } ) -instance : IsIsofibration.HasPushforwards IsIsofibration := - fun F _ G => { - has_representation := ⟨pushforward F.2 G.2, ⟨{ - homEquiv := pushforwardHomEquiv .. - homEquiv_comp f g := pushforwardHomEquiv_comp F.2 G.2 f g }⟩⟩ } - -- This should follow from `Groupoidal.forget` being an isofibration. -- (If we manage to directly define the pushforward -- as a grothendieck construction) @@ -333,6 +327,10 @@ theorem isIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) (hG : IsIsofibration G) : IsIsofibration (pushforwardHom hF hG) := sorry +-- FIXME. For some reason needed in the proof +-- `IsIsofibration.IsStableUnderPushforward IsIsofibration` +instance IsIsofibration.RespectsIso : IsIsofibration.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, @@ -349,7 +347,7 @@ instance : IsIsofibration.IsStableUnderPushforward IsIsofibration where of_isPushforward F G P := by intro h have p: (Over.mk P) ≅ Grpd.pushforward (F.snd) (G.snd) := - IsPushforward.Grpd.pushforward F.snd (Over.mk G.fst) G.snd (Over.mk P) h + isoPushforwardOfIsPushforward F.snd (Over.mk G.fst) G.snd (Over.mk P) h have i1 : IsIsofibration (pushforwardHom (F.snd) (G.snd)) := by apply isIsofibration_pushforward have e : P = (p.hom).left ≫ (pushforwardHom (F.snd) (G.snd)) := by From 01a5862351dcd3de98e672fa8911bdd9b6ce275c Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sun, 5 Oct 2025 16:15:44 -0400 Subject: [PATCH 26/59] problem with classifier at line 171 --- HoTTLean/Groupoids/IsIsofibration1.lean | 417 ++++++++++++++++++++++++ 1 file changed, 417 insertions(+) create mode 100644 HoTTLean/Groupoids/IsIsofibration1.lean diff --git a/HoTTLean/Groupoids/IsIsofibration1.lean b/HoTTLean/Groupoids/IsIsofibration1.lean new file mode 100644 index 00000000..4f0a0833 --- /dev/null +++ b/HoTTLean/Groupoids/IsIsofibration1.lean @@ -0,0 +1,417 @@ +import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction +import Mathlib.CategoryTheory.FiberedCategory.HomLift +import Mathlib.CategoryTheory.FiberedCategory.Fiber +import HoTTLean.ForMathlib.CategoryTheory.Grpd +import HoTTLean.ForMathlib.CategoryTheory.FreeGroupoid +import HoTTLean.Groupoids.Pi + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section + +namespace GroupoidModel.FunctorOperation.pi + +open CategoryTheory Functor.Groupoidal + +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_naturality])) + (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_naturality, 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] + +-- TODO: work out naturality equations for this bijection + +end GroupoidModel.FunctorOperation.pi + +namespace CategoryTheory + +open Functor.Groupoidal + +structure Functor.Isofibration {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') + + +lemma obj_liftObj {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + (F : C ⥤ D) (hF : F.Isofibration) {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X): + F.obj (hF.liftObj f hX') = Y := by + have i : F.IsHomLift f (hF.liftIso f hX') := hF.isHomLift .. + apply @IsHomLift.codomain_eq _ _ _ _ F _ _ _ _ f (hF.liftIso f hX') + + +lemma map_liftIso {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + (F : C ⥤ D) (hF : F.Isofibration) {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X): + eqToHom hX'.symm ≫ F.map (hF.liftIso f hX') ≫ eqToHom (obj_liftObj ..) = f := by + have i : F.IsHomLift f (hF.liftIso f hX') := hF.isHomLift .. + symm + apply IsHomLift.fac + + +lemma map_liftIso' {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + (F : C ⥤ D) (hF : F.Isofibration) {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X): + F.map (hF.liftIso f hX') = eqToHom hX' ≫ f ≫ eqToHom (by simp[obj_liftObj]) := by + simp[← map_liftIso F hF f hX'] + + +namespace Functor.Isofibration + +variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} + (hF : F.Isofibration) + +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 + +/-- Any isofibration `F : E ⥤ Γ` of groupoids is classified by a functor `classifier : Γ ⥤ Grpd`. +-/ + +def classifier.map.obj.eq {X Y} (f : X ⟶ Y) (a : F.Fiber X) : + F.obj (hF.liftObj f a.2) = Y := by + have p : F.IsHomLift f (hF.liftIso f _) := hF.isHomLift f (X' := a.1) a.2 + apply @IsHomLift.codomain_eq (f := f) (φ := liftIso (X' := a.1) hF f a.2) + +def classifier.map.obj {X Y} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := + ⟨liftObj hF f a.2, classifier.map.obj.eq ..⟩ + +lemma Fiber.map {X} {a b: F.Fiber X} (m: a ⟶ b) : + F.map m.1 = eqToHom a.2 ≫ 𝟙 X ≫ eqToHom b.2.symm := by + have e:= m.2 + apply IsHomLift.fac' + + +def classifier.map.map {X Y} (f: X ⟶ Y) {a b: F.Fiber X} (m: a ⟶ b) : + map.obj hF f a ⟶ map.obj hF f b := by + let i1 : a.1 ⟶ liftObj hF f a.2 := liftIso hF f a.2 + let i2 := liftIso hF f b.2 + let i := Groupoid.inv i1 ≫ m.1 ≫ i2 + have e :𝟙 Y = eqToHom (by simp[obj_liftObj]) ≫ + F.map (CategoryTheory.inv i1 ≫ m.1 ≫ i2) ≫ eqToHom (by simp[obj_liftObj]) + := by + simp[i1, i2,Fiber.map, Functor.map_inv,map_liftIso'] + exact ⟨ i, + by + simp only[i, e] + apply IsHomLift.of_fac _ _ _ (by apply classifier.map.obj.eq) (by apply classifier.map.obj.eq) + simp + ⟩ + + +lemma classifier.map.map_id {X Y} (f: X ⟶ Y) (a: F.Fiber X): + map.map hF f (𝟙 a) = 𝟙 (map.obj hF f a) := by + simp[classifier.map.map] + ext + simp[Fiber.fiberInclusion] + simp[CategoryStruct.id] + simp[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 hF f (m1 ≫ m2) = map.map hF f m1 ≫ map.map hF f m2 := by + simp[classifier.map.map] + ext + simp[Fiber.fiberInclusion] + simp[classifier.map.obj,CategoryStruct.comp] + + +def classifier.map {X Y} (f: X ⟶ Y) : (Grpd.of (F.Fiber X) ⟶ Grpd.of (F.Fiber Y)) where + obj := classifier.map.obj hF f + map := classifier.map.map hF f + map_id := classifier.map.map_id hF f + map_comp := classifier.map.map_comp hF f + +lemma classifier.map_id (X : Γ) : classifier.map hF (𝟙 X) = 𝟙 (Grpd.of (F.Fiber X)) := sorry + + +def classifier : Γ ⥤ Grpd.{v,u} where + obj X := Grpd.of (F.Fiber X) + map := classifier.map hF + map_id := classifier.map_id hF + map_comp := by sorry + +/-- The Grothendieck construction on the classifier is isomorphic to `E`. +TODO: add commuting triangles for `Grothendieck.forget` and `F` with `.hom` and `.inv`. +TODO: draw pullback diagram. -/ +def grothendieckClassifierIso : ∫ classifier hF ≅≅ E where + hom := + sorry + inv := sorry + hom_inv_id := sorry + inv_hom_id := sorry + +end Functor.Isofibration + +namespace Grpd + +attribute [simp] comp_eq_comp id_eq_id in +@[simps] +def Grpd.mkIso {Δ Γ : Grpd} (F : Δ ≅≅ Γ) : Δ ≅ Γ where + hom := F.hom + inv := F.inv + hom_inv_id := by simp + inv_hom_id := by simp + +namespace IsIsofibration + +def isofibration {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : F.Isofibration := sorry + +/-- The Grothendieck construction on the classifier is isomorphic to `E`, +now as objects in `Grpd`. -/ +def grothendieckClassifierIso {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : + Grpd.of (∫ hF.isofibration.classifier) ≅ B := + Grpd.mkIso (Functor.Isofibration.grothendieckClassifierIso ..) + +-- lemma grothendieckClassifierIso_hom_comp_eq_forget {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : +-- hF.grothendieckClassifierIso.hom ⋙ F = homOf Functor.Groupoidal.forget := +-- sorry + +lemma grothendieckClassifierIso_inv_comp_forget {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : + hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := + sorry + +end IsIsofibration + +instance : IsIsofibration.IsStableUnderBaseChange := by + dsimp [IsIsofibration] + infer_instance + +instance : IsIsofibration.IsMultiplicative := by + dsimp [IsIsofibration] + infer_instance + +instance : IsIsofibration.HasObjects := by + sorry + +section + +attribute [local instance] Grpd.IsIsofibration.isofibration + +open Functor.Isofibration + +def strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) (G : C ⟶ B) : + C ⟶ Grpd.of (∫ classifier (hF.isofibration)) := + G ≫ hF.grothendieckClassifierIso.inv + +def isIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsIsofibration (strictify hF G) := sorry + +def isofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : (strictify hF G).Isofibration := sorry + +/-- 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : Grpd := + Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.isofibration.classifier) + (classifier (isofibration_strictify hF hG))) + +/-- 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : Over A := + Over.mk (pushforwardHom hF hG) + +lemma pushforward.hom {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : + (pushforward hF hG).hom = pushforwardHom .. := rfl + +open Limits in +lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : IsIsofibration 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 : IsIsofibration F) (σ : Over A) : + IsPullback (homOf (pre hF.isofibration.classifier σ.hom)) (homOf Functor.Groupoidal.forget) + (homOf Functor.Groupoidal.forget) (homOf σ.hom) := by + have outer_pb := Functor.Groupoidal.isPullback (σ.hom ⋙ hF.isofibration.classifier) + have right_pb := Functor.Groupoidal.isPullback (hF.isofibration.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 pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : IsIsofibration F) (σ : Over A) : + Grpd.of (∫ σ.hom ⋙ hF.isofibration.classifier) ≅ Limits.pullback σ.hom F := + (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) + +open GroupoidModel.FunctorOperation.pi in +/-- `∫ σ.hom ⋙ hF.isofibration.classifier` is the pullback of `F` along `σ`, +`∫ (isofibration_strictify hF hG).classifier` is isomorphic to `G`. +So up to isomorphism this is the hom set bijection we want. -/ +def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ + {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } where + toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ + invFun f := Over.homMk (equivInv _ f.1 f.2) + (equivInv_comp_forget ..) + left_inv f := by + ext + simp [equivInv_equivFun] + right_inv f := by + ext + simp [equivFun_equivInv] + +def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (σ : Over A) : + { f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } ≃ + ((Over.pullback F).obj σ ⟶ Over.mk G) where + toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ + ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry + invFun f := ⟨(pullbackIsoGrothendieck hF σ).hom ≫ f.left ≫ + ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ + left_inv := sorry + right_inv := sorry + + +open GroupoidModel.FunctorOperation.pi in +/-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ +def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := + calc (σ ⟶ pushforward hF hG) + _ ≃ {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + (f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom)} := + pushforwardHomEquivAux1 .. + _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. + + + +/-- Naturality in the universal property of the pushforward. -/ +lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration 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 + sorry + + +def pushforward_isPushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) where + homEquiv := pushforwardHomEquiv .. + homEquiv_comp f g := pushforwardHomEquiv_comp hF hG f g + +instance : IsIsofibration.HasPushforwards IsIsofibration := + fun F _ G => { + has_representation := ⟨pushforward F.2 G.2, ⟨pushforward_isPushforward F.2 G.2⟩⟩ } + +def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : IsIsofibration F) + (G: Over B) (hG : IsIsofibration 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 isofibration. +-- (If we manage to directly define the pushforward +-- as a grothendieck construction) +theorem isIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsIsofibration (pushforwardHom hF hG) := + sorry + +-- FIXME. For some reason needed in the proof +-- `IsIsofibration.IsStableUnderPushforward IsIsofibration` +instance IsIsofibration.RespectsIso : IsIsofibration.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. Isofibrations are stable under isomorphism (this is in mathlib, for any `rlp`) + `MorphismProperty.rlp_isMultiplicative` + `MorphismProperty.respectsIso_of_isStableUnderComposition` + 3. The chosen pushforward is an isofibration `isIsofibration_pushforward` -/ + +instance : IsIsofibration.IsStableUnderPushforward IsIsofibration 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 : IsIsofibration (pushforwardHom (F.snd) (G.snd)) := by + apply isIsofibration_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 (IsIsofibration.RespectsIso).precomp + assumption From d77582ead1a88e222c40532715ddcccdf9a1f76a Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 6 Oct 2025 11:31:25 -0400 Subject: [PATCH 27/59] SplitClovenIsofibration --- .../CategoryTheory/IsIsofibration.lean | 0 .../CategoryTheory/SplitIsofibration.lean | 346 ++++++++++++++++++ HoTTLean/Groupoids/UnstructuredModel.lean | 1 - 3 files changed, 346 insertions(+), 1 deletion(-) delete mode 100644 HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean create mode 100644 HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/IsIsofibration.lean deleted file mode 100644 index e69de29b..00000000 diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean new file mode 100644 index 00000000..e52c1adf --- /dev/null +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -0,0 +1,346 @@ +import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction +import Mathlib.CategoryTheory.FiberedCategory.HomLift +import Mathlib.CategoryTheory.FiberedCategory.Fiber +import HoTTLean.ForMathlib.CategoryTheory.Grpd + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section + +namespace CategoryTheory + +namespace Functor + +namespace Fiber + +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 + +variable {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + +structure ClovenIsofibration (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') + +section +variable {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' + +lemma ClovenIsofibration.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 ClovenIsofibration.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 ClovenIsofibration.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'] + +lemma ClovenIsofibration.liftObjComp_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 + +end + +structure SplitClovenIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + (F : C ⥤ D) extends ClovenIsofibration F where + liftObjId {X : D} {X' : C} (hX' : F.obj X' = X) : liftObj (𝟙 X) hX' = X' + liftIsoId {X : D} {X' : C} (hX' : F.obj X' = X) : liftIso (𝟙 X) hX' = eqToHom (liftObjId hX').symm + liftObjComp {X Y Z : D} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : C} (hX' : F.obj X' = X) + (Y' : C) (hY' : liftObj f hX' = Y') : liftObj (f ≫ g) hX' = liftObj g (X' := Y') + (toClovenIsofibration.liftObjComp_aux f hX' Y' hY') + liftIsoComp {X Y Z : D} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : C} (hX' : F.obj X' = X) + (Y' : C) (hY' : liftObj f hX' = Y') : liftIso (f ≫ g) hX' = liftIso f hX' ≫ + eqToHom hY' ≫ + liftIso g (X' := Y') (toClovenIsofibration.liftObjComp_aux f hX' Y' hY') ≫ + eqToHom (liftObjComp f g hX' Y' hY').symm + +namespace SplitClovenIsofibration + +variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} + (I : SplitClovenIsofibration F) + +/-- Any isofibration `F : E ⥤ Γ` of groupoids is classified by a functor `classifier : Γ ⥤ Grpd`. +-/ +def classifier.map.obj {X Y : Γ} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := + ⟨I.liftObj f a.2, by + have p : F.IsHomLift f (I.liftIso f _) := I.isHomLift f (X' := a.1) a.2 + apply @IsHomLift.codomain_eq (f := f) (φ := I.liftIso (X' := a.1) f a.2) ⟩ + +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 := by + --let i1 : a ⟶ liftObj hF f a.2 := liftIso hF f a.2 + let i2 := I.liftIso f b.2 + --let i := m ≫ i2 + sorry + +def classifier.map {X Y} (f : X ⟶ Y) : F.Fiber X ⥤ F.Fiber Y where + obj := classifier.map.obj I f + map {a b} m := classifier.map.map I f m + map_id := sorry + map_comp := sorry + +def classifier : Γ ⥤ Grpd.{v,u} where + obj X := Grpd.of (F.Fiber X) + map f := + have : SplitClovenIsofibration F := I -- TODO: remove. This is just to ensure variables used + sorry -- use lifting of isomorphisms! + map_id := sorry + map_comp := sorry + +/-- The Grothendieck construction on the classifier is isomorphic to `E`. +TODO: add commuting triangles for `Grothendieck.forget` and `F` with `.hom` and `.inv`. +TODO: draw pullback diagram. -/ +def grothendieckClassifierIso : ∫ classifier hF ≅≅ E where + hom := + sorry + inv := sorry + hom_inv_id := sorry + inv_hom_id := sorry + +end Functor.Isofibration + +namespace Grpd + +attribute [simp] comp_eq_comp id_eq_id in +@[simps] +def Grpd.mkIso {Δ Γ : Grpd} (F : Δ ≅≅ Γ) : Δ ≅ Γ where + hom := F.hom + inv := F.inv + hom_inv_id := by simp + inv_hom_id := by simp + +namespace IsIsofibration + +def isofibration {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : F.Isofibration := sorry + +/-- The Grothendieck construction on the classifier is isomorphic to `E`, +now as objects in `Grpd`. -/ +def grothendieckClassifierIso {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : + Grpd.of (∫ hF.isofibration.classifier) ≅ B := + Grpd.mkIso (Functor.Isofibration.grothendieckClassifierIso ..) + +-- lemma grothendieckClassifierIso_hom_comp_eq_forget {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : +-- hF.grothendieckClassifierIso.hom ⋙ F = homOf Functor.Groupoidal.forget := +-- sorry + +lemma grothendieckClassifierIso_inv_comp_forget {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : + hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := + sorry + +end IsIsofibration + +instance : IsIsofibration.IsStableUnderBaseChange := by + dsimp [IsIsofibration] + infer_instance + +instance : IsIsofibration.IsMultiplicative := by + dsimp [IsIsofibration] + infer_instance + +instance : IsIsofibration.HasObjects := by + sorry + +section + +attribute [local instance] Grpd.IsIsofibration.isofibration + +open Functor.Isofibration + +def strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) (G : C ⟶ B) : + C ⟶ Grpd.of (∫ classifier (hF.isofibration)) := + G ≫ hF.grothendieckClassifierIso.inv + +def isIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsIsofibration (strictify hF G) := sorry + +def isofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : (strictify hF G).Isofibration := sorry + +/-- 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : Grpd := + Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.isofibration.classifier) + (classifier (isofibration_strictify hF hG))) + +/-- 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration 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 : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : Over A := + Over.mk (pushforwardHom hF hG) + +lemma pushforward.hom {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : + (pushforward hF hG).hom = pushforwardHom .. := rfl + +open Limits in +lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : IsIsofibration 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 : IsIsofibration F) (σ : Over A) : + IsPullback (homOf (pre hF.isofibration.classifier σ.hom)) (homOf Functor.Groupoidal.forget) + (homOf Functor.Groupoidal.forget) (homOf σ.hom) := by + have outer_pb := Functor.Groupoidal.isPullback (σ.hom ⋙ hF.isofibration.classifier) + have right_pb := Functor.Groupoidal.isPullback (hF.isofibration.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 pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : IsIsofibration F) (σ : Over A) : + Grpd.of (∫ σ.hom ⋙ hF.isofibration.classifier) ≅ Limits.pullback σ.hom F := + (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) + +open GroupoidModel.FunctorOperation.pi in +/-- `∫ σ.hom ⋙ hF.isofibration.classifier` is the pullback of `F` along `σ`, +`∫ (isofibration_strictify hF hG).classifier` is isomorphic to `G`. +So up to isomorphism this is the hom set bijection we want. -/ +def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ + {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } where + toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ + invFun f := Over.homMk (equivInv _ f.1 f.2) + (equivInv_comp_forget ..) + left_inv f := by + ext + simp [equivInv_equivFun] + right_inv f := by + ext + simp [equivFun_equivInv] + +def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (σ : Over A) : + { f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } ≃ + ((Over.pullback F).obj σ ⟶ Over.mk G) where + toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ + ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry + invFun f := ⟨(pullbackIsoGrothendieck hF σ).hom ≫ f.left ≫ + ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ + left_inv := sorry + right_inv := sorry + +open GroupoidModel.FunctorOperation.pi in +/-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ +def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := + calc (σ ⟶ pushforward hF hG) + _ ≃ {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + (f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom)} := + pushforwardHomEquivAux1 .. + _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. + + + +/-- Naturality in the universal property of the pushforward. -/ +lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration 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 + sorry + + +def pushforward_isPushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) where + homEquiv := pushforwardHomEquiv .. + homEquiv_comp f g := pushforwardHomEquiv_comp hF hG f g + +instance : IsIsofibration.HasPushforwards IsIsofibration := + fun F _ G => { + has_representation := ⟨pushforward F.2 G.2, ⟨pushforward_isPushforward F.2 G.2⟩⟩ } + +def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : IsIsofibration F) + (G: Over B) (hG : IsIsofibration 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 isofibration. +-- (If we manage to directly define the pushforward +-- as a grothendieck construction) +theorem isIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} + (hG : IsIsofibration G) : IsIsofibration (pushforwardHom hF hG) := + sorry + +-- FIXME. For some reason needed in the proof +-- `IsIsofibration.IsStableUnderPushforward IsIsofibration` +instance IsIsofibration.RespectsIso : IsIsofibration.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. Isofibrations are stable under isomorphism (this is in mathlib, for any `rlp`) + `MorphismProperty.rlp_isMultiplicative` + `MorphismProperty.respectsIso_of_isStableUnderComposition` + 3. The chosen pushforward is an isofibration `isIsofibration_pushforward` -/ + +instance : IsIsofibration.IsStableUnderPushforward IsIsofibration 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 : IsIsofibration (pushforwardHom (F.snd) (G.snd)) := by + apply isIsofibration_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 (IsIsofibration.RespectsIso).precomp + assumption diff --git a/HoTTLean/Groupoids/UnstructuredModel.lean b/HoTTLean/Groupoids/UnstructuredModel.lean index f154dbea..23b7ce87 100644 --- a/HoTTLean/Groupoids/UnstructuredModel.lean +++ b/HoTTLean/Groupoids/UnstructuredModel.lean @@ -4,7 +4,6 @@ import Mathlib.CategoryTheory.Category.Cat.Limit import HoTTLean.Model.UHom import HoTTLean.Grothendieck.Groupoidal.IsPullback import HoTTLean.Groupoids.IsPullback -import HoTTLean.ForMathlib.CategoryTheory.IsIsofibration /-! Here we construct universes for the groupoid natural model. From 69304106aa04d670e6617d777686a62131e8d06f Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 6 Oct 2025 12:25:41 -0400 Subject: [PATCH 28/59] feat: SplitClovenIsofibration --- HoTTLean/ForMathlib/CategoryTheory/Grpd.lean | 12 ++ .../CategoryTheory/SplitIsofibration.lean | 133 ++++++++++++++---- HoTTLean/Groupoids/IsIsofibration.lean | 1 + 3 files changed, 119 insertions(+), 27 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean index 1189506f..915cc897 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean @@ -226,4 +226,16 @@ lemma Grpd.NatTrans.hext {X X' Y Y' : Grpd.{v,u}} (hX : X = X') (hY : Y = Y') aesop_cat end + +namespace Grpd + +attribute [simp] comp_eq_comp id_eq_id in +@[simps] +def Grpd.mkIso {Δ Γ : Grpd} (F : Δ ≅≅ Γ) : Δ ≅ Γ where + hom := F.hom + inv := F.inv + hom_inv_id := by simp + inv_hom_id := by simp + +end Grpd end CategoryTheory diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index e52c1adf..be0acf86 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -1,7 +1,7 @@ import Mathlib.CategoryTheory.MorphismProperty.OverAdjunction import Mathlib.CategoryTheory.FiberedCategory.HomLift import Mathlib.CategoryTheory.FiberedCategory.Fiber -import HoTTLean.ForMathlib.CategoryTheory.Grpd +import HoTTLean.Grothendieck.Groupoidal.IsPullback universe w v u v₁ u₁ v₂ u₂ v₃ u₃ @@ -76,6 +76,8 @@ structure SplitClovenIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] namespace SplitClovenIsofibration +open ClovenIsofibration + variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} (I : SplitClovenIsofibration F) @@ -86,52 +88,129 @@ def classifier.map.obj {X Y : Γ} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := have p : F.IsHomLift f (I.liftIso f _) := I.isHomLift f (X' := a.1) a.2 apply @IsHomLift.codomain_eq (f := f) (φ := I.liftIso (X' := a.1) f a.2) ⟩ -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 := by - --let i1 : a ⟶ liftObj hF f a.2 := liftIso hF f a.2 +lemma classifier.fac' {X} {a b : F.Fiber X} (m : a ⟶ b) : + F.map m.1 = eqToHom (by rw [a.2, b.2]) := by + rw [@IsHomLift.fac' _ _ _ _ F _ _ _ _ (𝟙 X) _ m.2] + simp + +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 := m ≫ i2 - sorry + let i := Groupoid.inv i1 ≫ m.1 ≫ i2 + have e :𝟙 Y = eqToHom (by simp[obj_liftObj]) ≫ + F.map (CategoryTheory.inv i1 ≫ m.1 ≫ i2) ≫ eqToHom (by simp[obj_liftObj]) + := by + simp[i1, i2, classifier.fac', 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[classifier.map.map] + simp[Fiber.fiberInclusion] + simp[CategoryStruct.id] + simp[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] + simp[CategoryStruct.comp] +@[simps] def classifier.map {X Y} (f : X ⟶ Y) : F.Fiber X ⥤ F.Fiber Y where obj := classifier.map.obj I f - map {a b} m := classifier.map.map I f m - map_id := sorry - map_comp := sorry + map := classifier.map.map I f + map_id := classifier.map.map_id I f + map_comp := classifier.map.map_comp I f + +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, I.liftObjId] + · intro a b f + simp + ext + simp [map.map, I.liftIsoId, eqToHom_map, Grpd.id_eq_id, ← heq_eq_eq] + rfl def classifier : Γ ⥤ Grpd.{v,u} where obj X := Grpd.of (F.Fiber X) - map f := - have : SplitClovenIsofibration F := I -- TODO: remove. This is just to ensure variables used - sorry -- use lifting of isomorphisms! - map_id := sorry + map f := Grpd.homOf (classifier.map I f) + map_id _ := classifier.map_id .. map_comp := sorry +open CategoryTheory.Functor.Groupoidal + /-- The Grothendieck construction on the classifier is isomorphic to `E`. TODO: add commuting triangles for `Grothendieck.forget` and `F` with `.hom` and `.inv`. TODO: draw pullback diagram. -/ -def grothendieckClassifierIso : ∫ classifier hF ≅≅ E where +def grothendieckClassifierIso : ∫ (@classifier Γ E _ _ F I) ≅≅ E where hom := sorry inv := sorry hom_inv_id := sorry inv_hom_id := sorry -end Functor.Isofibration - -namespace Grpd - -attribute [simp] comp_eq_comp id_eq_id in -@[simps] -def Grpd.mkIso {Δ Γ : Grpd} (F : Δ ≅≅ Γ) : Δ ≅ Γ where - hom := F.hom - inv := F.inv - hom_inv_id := by simp - inv_hom_id := by simp - +/-- `IsMultiplicative` 1/2 -/ +def id {A : Type u} [Category.{v} A] : + SplitClovenIsofibration (𝟭 A) where + liftObj := sorry + liftIso := sorry + isHomLift := sorry + liftObjId := sorry + liftIsoId := sorry + liftObjComp := sorry + liftIsoComp := sorry + +/-- `IsMultiplicative` 1/2 -/ +def comp {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} + (IF : SplitClovenIsofibration F) {G : B ⥤ C} (IG : SplitClovenIsofibration G) : + SplitClovenIsofibration (F ⋙ G) where + liftObj := sorry + liftIso := sorry + isHomLift := sorry + liftObjId := sorry + liftIsoId := sorry + liftObjComp := sorry + liftIsoComp := sorry + +/-- `IsStableUnderBaseChange` -/ +def ofIsPullback {A B A' B' : 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 : SplitClovenIsofibration F) : + SplitClovenIsofibration F' where + liftObj := sorry + liftIso := sorry + isHomLift := sorry + liftObjId := sorry + liftIsoId := sorry + liftObjComp := sorry + liftIsoComp := sorry + +-- 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 : SplitClovenIsofibration F) : +-- SplitClovenIsofibration F' where +-- liftObj := sorry +-- liftIso := sorry +-- isHomLift := sorry +-- liftObjId := sorry +-- liftIsoId := sorry +-- liftObjComp := sorry +-- liftIsoComp := sorry + +#exit namespace IsIsofibration -def isofibration {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : F.Isofibration := sorry +def isofibration B A : Grpd {F : B ⟶ A} (hF : IsIsofibration F) : F.Isofibration := sorry /-- The Grothendieck construction on the classifier is isomorphic to `E`, now as objects in `Grpd`. -/ diff --git a/HoTTLean/Groupoids/IsIsofibration.lean b/HoTTLean/Groupoids/IsIsofibration.lean index 014c63ff..4102263f 100644 --- a/HoTTLean/Groupoids/IsIsofibration.lean +++ b/HoTTLean/Groupoids/IsIsofibration.lean @@ -112,6 +112,7 @@ def classifier.map {X Y} (f: X ⟶ Y) : (Grpd.of (F.Fiber X) ⟶ Grpd.of (F.Fibe map_id := sorry map_comp := sorry +-- DEPRECATED: we think `map_id, map_comp` are impossible to prove def classifier : Γ ⥤ Grpd.{v,u} where obj X := Grpd.of (F.Fiber X) map f := From 5314dc4f15df657e73149ba1f51deb091fbd9fda Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Tue, 7 Oct 2025 09:14:07 -0400 Subject: [PATCH 29/59] problem on line 256 --- .../CategoryTheory/SplitIsofibration.lean | 138 +++++++++++++++++- 1 file changed, 132 insertions(+), 6 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index be0acf86..9adffbbc 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -141,28 +141,154 @@ lemma classifier.map_id (X : Γ) : classifier.map I (𝟙 X) = 𝟙 (Grpd.of (F. simp [map.map, I.liftIsoId, eqToHom_map, Grpd.id_eq_id, ← heq_eq_eq] rfl + +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, I.liftObjComp] + · intro a b f + simp + ext + simp [map.map, eqToHom_map, Grpd.id_eq_id, ← heq_eq_eq,← Category.assoc] + simp[I.liftIsoComp,← Category.assoc] + congr 1 + simp[Category.assoc] + congr + simp[] + + + 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 := sorry + map_comp := by + apply classifier.map_comp open CategoryTheory.Functor.Groupoidal /-- The Grothendieck construction on the classifier is isomorphic to `E`. TODO: add commuting triangles for `Grothendieck.forget` and `F` with `.hom` and `.inv`. TODO: draw pullback diagram. -/ -def grothendieckClassifierIso : ∫ (@classifier Γ E _ _ F I) ≅≅ E where - hom := - sorry - inv := sorry + +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.hom.map_aux +-- {X Y: Γ} (f: X ⟶ Y) (a: I.classifier.obj X) (b: I.classifier.obj Y) +-- (h: (I.classifier.map f).obj a ⟶ b ) +-- : (I.classifier.map f).obj a = sorry := by + +-- simp[classifier,classifier.map.obj] +-- sorry + + +/- + +Want: F.obj ↑p1.fiber = p1.base + +p1 : ∫ I.classifier + +p1.base : Γ + +p1.fiber : I.classifier.obj p1.base + + Grpd.of (F.Fiber p1.base) = +I.classifier.obj p1.base = F.Fiber p1.base + +p1.fiber : F.Fiber p1.base + +F.obj p1.fiber = p1.base + +-/ + +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 [liftIsoId, eqToHom_map] + --convert_to + -- rw! (castMode := .all) [Grpd.id_eq_id,hom.map_aux,liftObjId] + + +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 + --convert_to _ ≫ _ ≫ Fiber.fiberInclusion.map (Hom.fiber (𝟙 X)) = _ + simp [map',liftIsoComp,classifier] + congr 1 + convert_to _ ≫ _ ≫ _ ≫ _ ≫ _ = _ + simp[← Category.assoc] + congr 1 + simp[classifier.map.map] + simp[← Category.assoc] + congr + simp[Category.assoc] + simp[Hom.fiber] + congr + --simp[Category.assoc] + + sorry + --convert_to _ ≫ eqToHom _ ≫ Fiber.fiberInclusion.map _ ≫ _ = _ + + +def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E where + obj p := p.fiber.1 + map := grothendieckClassifierIso.hom.map I + map_id X := by apply grothendieckClassifierIso.hom.map_id .. + map_comp := sorry--grothendieckClassifierIso.hom.map_comp I + + +def grothendieckClassifierIso.inv : E ⥤ ∫ I.classifier where + obj := sorry + map := sorry + map_id := sorry + map_comp := sorry + + +def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where + hom := grothendieckClassifierIso.hom .. + inv := grothendieckClassifierIso.inv .. hom_inv_id := sorry inv_hom_id := sorry + + /-- `IsMultiplicative` 1/2 -/ +def id.liftObj {A : Type u} [Category.{v} A] {X Y} + (f : X ⟶ Y) [IsIso f] {X' : A} (e : (𝟭 A).obj X' = X) : A := X + def id {A : Type u} [Category.{v} A] : SplitClovenIsofibration (𝟭 A) where - liftObj := sorry + liftObj := id.liftObj liftIso := sorry isHomLift := sorry liftObjId := sorry From c14cc51842bfca4827ec4beca6cada19d261e8c3 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 7 Oct 2025 09:29:46 -0400 Subject: [PATCH 30/59] feat: use functorFrom and map_comp --- .../CategoryTheory/SplitIsofibration.lean | 31 ++++++++++++------- 1 file changed, 19 insertions(+), 12 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 9adffbbc..2d9202bf 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -242,24 +242,31 @@ hom.map I (𝟙 X) = 𝟙 _ := by 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', liftIsoComp, eqToHom_map, classifier, classifier.map.map] + rfl --convert_to _ ≫ _ ≫ Fiber.fiberInclusion.map (Hom.fiber (𝟙 X)) = _ - simp [map',liftIsoComp,classifier] - congr 1 - convert_to _ ≫ _ ≫ _ ≫ _ ≫ _ = _ - simp[← Category.assoc] - congr 1 - simp[classifier.map.map] - simp[← Category.assoc] - congr - simp[Category.assoc] - simp[Hom.fiber] - congr + +-- simp [map', liftIsoComp] +-- simp [map',liftIsoComp,classifier] +-- congr 1 +-- convert_to _ ≫ _ ≫ _ ≫ _ ≫ _ = _ +-- simp[← Category.assoc] +-- congr 1 +-- simp[classifier.map.map] +-- simp[← Category.assoc] +-- congr +-- simp[Category.assoc] +-- simp[Hom.fiber] +-- congr --simp[Category.assoc] - sorry +-- sorry --convert_to _ ≫ eqToHom _ ≫ Fiber.fiberInclusion.map _ ≫ _ = _ +def grothendieckClassifierIso.hom' : ∫ I.classifier ⥤ E := + Groupoidal.functorFrom (fun x => Fiber.fiberInclusion) (fun f => sorry) sorry sorry + def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E where obj p := p.fiber.1 map := grothendieckClassifierIso.hom.map I From 7b3ea9f6a4d787791874dcec1d841c3a6bd80c62 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Tue, 7 Oct 2025 11:59:35 -0400 Subject: [PATCH 31/59] problem on line 286 --- .../CategoryTheory/SplitIsofibration.lean | 44 +++++++++++++------ 1 file changed, 30 insertions(+), 14 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 2d9202bf..e856da47 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -263,22 +263,38 @@ hom.map' I (f ≫ g) = hom.map' I f ≫ hom.map' I g := by -- sorry --convert_to _ ≫ eqToHom _ ≫ Fiber.fiberInclusion.map _ ≫ _ = _ - -def grothendieckClassifierIso.hom' : ∫ I.classifier ⥤ E := - Groupoidal.functorFrom (fun x => Fiber.fiberInclusion) (fun f => sorry) sorry sorry - -def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E where - obj p := p.fiber.1 - map := grothendieckClassifierIso.hom.map I - map_id X := by apply grothendieckClassifierIso.hom.map_id .. - map_comp := sorry--grothendieckClassifierIso.hom.map_comp I +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,liftIsoId]) + (by intro X Y Z f g; ext; simp[hom'.hom,liftIsoComp]) + +-- def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E where +-- obj p := p.fiber.1 +-- map := grothendieckClassifierIso.hom.map I +-- map_id X := by apply grothendieckClassifierIso.hom.map_id .. +-- map_comp := sorry--grothendieckClassifierIso.hom.map_comp I + +def grothendieckClassifierIso.inv.fibMap {X Y}(f : X ⟶ Y) : + ((F ⋙ I.classifier).map f).obj ⟨X,rfl⟩ ⟶ ⟨Y, rfl⟩ := by + simp[classifier] + -- exact (Fiber.homMk sorry sorry sorry) + --apply (I.liftIso f ..).inv + sorry -def grothendieckClassifierIso.inv : E ⥤ ∫ I.classifier where - obj := sorry - map := sorry - map_id := sorry - map_comp := sorry +def grothendieckClassifierIso.inv : E ⥤ ∫ I.classifier := + Groupoidal.functorTo F (fun x => ⟨x, rfl⟩) + (fun f => grothendieckClassifierIso.inv.fibMap I f) + sorry sorry def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where From 1a597ce6cbdb85953f4cc51cbcd1d3031e00453e Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 7 Oct 2025 20:24:39 -0400 Subject: [PATCH 32/59] feat: Functor.SplitClovenFibration.id --- .../CategoryTheory/Functor/IsPullback.lean | 30 +- HoTTLean/ForMathlib/CategoryTheory/Grpd.lean | 32 +- .../CategoryTheory/SplitIsofibration.lean | 25 +- .../Groupoids/SplitClovenIsofibration.lean | 285 ++++++++++++++++++ 4 files changed, 346 insertions(+), 26 deletions(-) create mode 100644 HoTTLean/Groupoids/SplitClovenIsofibration.lean diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean index 0e7dc475..0e00c2f0 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean @@ -1,6 +1,7 @@ import HoTTLean.ForMathlib import Mathlib.CategoryTheory.Widesubcategory import HoTTLean.ForMathlib.CategoryTheory.Functor.Iso +import HoTTLean.ForMathlib.CategoryTheory.FreeGroupoid universe v u v₁ u₁ v₂ u₂ v₃ u₃ @@ -796,6 +797,22 @@ def isPullback : IsPullback (homOf north) (homOf west) (homOf east) IsPullback.of_isLimit (PullbackCone.IsLimit.mk comm_sq (lift h) (fac_left _) (fac_right _) (uniq _)) +noncomputable def functorIsPullback + (h : IsPullback (homOf north) (homOf west) (homOf east) (homOf south)) : + Functor.IsPullback north west east south := by + have hChosen : IsPullback (P := Cat.of (Functor.IsPullback.Chosen east south)) + (homOf IsPullback.Chosen.north) (homOf IsPullback.Chosen.west) (homOf east) + (homOf south) := + isPullback Functor.IsPullback.Chosen.comm_sq (Functor.IsPullback.Chosen.isPullback east south) + let i := IsPullback.isoIsPullback _ _ h hChosen + convert Functor.IsPullback.ofIsoChosen east south i.hom i.inv ?_ ?_ + · symm + exact IsPullback.isoIsPullback_hom_fst _ _ h hChosen + · symm + exact IsPullback.isoIsPullback_hom_snd _ _ h hChosen + · exact i.hom_inv_id + · exact i.inv_hom_id + end end Cat @@ -824,11 +841,20 @@ def uniq (m : s.pt ⟶ of Libya) (hl : m ≫ homOf north = s.fst) · convert (fac_left h s).symm · convert (fac_right h s).symm -def isPullback : IsPullback (homOf north) (homOf west) (homOf east) - (homOf south) := +def isPullback : IsPullback (homOf north) (homOf west) (homOf east) (homOf south) := IsPullback.of_isLimit (PullbackCone.IsLimit.mk h.comm_sq (lift h) (fac_left _) (fac_right _) (uniq _)) +noncomputable def functorIsPullback {Libya Egypt Chad Sudan : Type v} [Groupoid.{v} Libya] + [Groupoid.{v} Egypt] [Groupoid.{v} Chad] [Groupoid.{v} Sudan] + {north : Libya ⥤ Egypt} {west : Libya ⥤ Chad} + {east : Egypt ⥤ Sudan} {south : Chad ⥤ Sudan} + (h : IsPullback (homOf north) (homOf west) (homOf east) (homOf south)) : + Functor.IsPullback north west east south := + Cat.functorIsPullback <| + @Functor.map_isPullback _ _ _ _ Grpd.forgetToCat (Grpd.of Libya) (Grpd.of Egypt) (Grpd.of Chad) + (Grpd.of Sudan) (homOf north) (homOf west) (homOf east) (homOf south) _ h + end Grpd /-- diff --git a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean index 915cc897..88cf0f60 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean @@ -127,28 +127,28 @@ theorem eqToHom_hom {C1 C2 : Grpd.{v,u}} {x y: C1} (f : x ⟶ y) (eq : C1 = C2) open MonoidalCategory MorphismProperty -def Interval : Type u := Codiscrete (ULift Bool) +-- def Interval : Type u := Codiscrete (ULift Bool) -instance : Groupoid (Codiscrete Bool) where - inv f := ⟨⟩ - inv_comp := by aesop - comp_inv := by aesop +-- instance : Groupoid (Codiscrete Bool) where +-- inv f := ⟨⟩ +-- inv_comp := by aesop +-- comp_inv := by aesop -namespace IsIsofibration +-- namespace IsIsofibration -def generatingTrivialCofibrationHom : 𝟙_ Grpd ⟶ Grpd.of $ AsSmall $ Codiscrete Bool where - obj X := ⟨⟨.false⟩⟩ - map _ := ⟨⟨⟩⟩ - map_id := by aesop - map_comp := by aesop +-- def generatingTrivialCofibrationHom : 𝟙_ Grpd ⟶ Grpd.of $ AsSmall $ Codiscrete Bool where +-- obj X := ⟨⟨.false⟩⟩ +-- map _ := ⟨⟨⟩⟩ +-- map_id := by aesop +-- map_comp := by aesop -def generatingTrivialCofibration : MorphismProperty Grpd.{u,u} := - ofHoms (fun _ : Unit => generatingTrivialCofibrationHom) +-- def generatingTrivialCofibration : MorphismProperty Grpd.{u,u} := +-- ofHoms (fun _ : Unit => generatingTrivialCofibrationHom) -end IsIsofibration +-- end IsIsofibration -def IsIsofibration : MorphismProperty Grpd := - rlp $ IsIsofibration.generatingTrivialCofibration +-- def IsIsofibration : MorphismProperty Grpd := +-- rlp $ IsIsofibration.generatingTrivialCofibration end Grpd diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index e856da47..80214363 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -309,15 +309,24 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where def id.liftObj {A : Type u} [Category.{v} A] {X Y} (f : X ⟶ Y) [IsIso f] {X' : A} (e : (𝟭 A).obj X' = X) : A := X +def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : + SplitClovenIsofibration 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) + liftObjId h := by simp [← h, ← Functor.comp_obj] + liftIsoId := by simp + liftObjComp := by simp + liftIsoComp := by simp + def id {A : Type u} [Category.{v} A] : - SplitClovenIsofibration (𝟭 A) where - liftObj := id.liftObj - liftIso := sorry - isHomLift := sorry - liftObjId := sorry - liftIsoId := sorry - liftObjComp := sorry - liftIsoComp := sorry + SplitClovenIsofibration (𝟭 A) := + iso <| Functor.Iso.refl _ /-- `IsMultiplicative` 1/2 -/ def comp {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} diff --git a/HoTTLean/Groupoids/SplitClovenIsofibration.lean b/HoTTLean/Groupoids/SplitClovenIsofibration.lean new file mode 100644 index 00000000..82c3e40a --- /dev/null +++ b/HoTTLean/Groupoids/SplitClovenIsofibration.lean @@ -0,0 +1,285 @@ +import HoTTLean.ForMathlib.CategoryTheory.SplitIsofibration +import HoTTLean.Groupoids.Pi + +universe w v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section + +namespace GroupoidModel.FunctorOperation.pi + +open CategoryTheory Functor.Groupoidal + +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_naturality])) + (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_naturality, 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] + +-- TODO: work out naturality equations for this bijection + +end GroupoidModel.FunctorOperation.pi + +namespace CategoryTheory + +open Functor.Groupoidal + +namespace Grpd + +def SplitClovenIsofibration : MorphismProperty Grpd := + fun _ _ F => Nonempty F.SplitClovenIsofibration + +namespace SplitClovenIsofibration + +variable {B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) + +def splitClovenIsofibration : F.SplitClovenIsofibration := Classical.choice hF + +/-- The Grothendieck construction on the classifier is isomorphic to `E`, +now as objects in `Grpd`. -/ +def grothendieckClassifierIso : Grpd.of (∫ hF.splitClovenIsofibration.classifier) ≅ B := + Grpd.mkIso (Functor.SplitClovenIsofibration.grothendieckClassifierIso ..) + +end SplitClovenIsofibration + +instance : SplitClovenIsofibration.IsStableUnderBaseChange.{u,u} where + of_isPullback pb hG := + ⟨ Functor.SplitClovenIsofibration.ofIsPullback _ _ _ _ + (Grpd.functorIsPullback pb) hG.splitClovenIsofibration ⟩ + +instance : SplitClovenIsofibration.IsMultiplicative where + id_mem _ := ⟨ Functor.SplitClovenIsofibration.id ⟩ + comp_mem _ _ hF hG := ⟨ Functor.SplitClovenIsofibration.comp + hF.splitClovenIsofibration hG.splitClovenIsofibration ⟩ + + -- infer_instance + +instance : SplitClovenIsofibration.HasObjects := by + sorry + +section + +attribute [local instance] Grpd.SplitClovenIsofibration.isofibration + +open Functor.Isofibration + +def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) (G : C ⟶ B) : + C ⟶ Grpd.of (∫ classifier (hF.isofibration)) := + G ≫ hF.grothendieckClassifierIso.inv + +def isIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) : SplitClovenIsofibration (strictify hF G) := sorry + +def isofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) : (strictify hF G).Isofibration := sorry + +/-- 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 : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) : Grpd := + Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.isofibration.classifier) + (classifier (isofibration_strictify hF hG))) + +/-- 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 : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration 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 : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) : Over A := + Over.mk (pushforwardHom hF hG) + +lemma pushforward.hom {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) : + (pushforward hF hG).hom = pushforwardHom .. := rfl + +open Limits in +lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration 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 : SplitClovenIsofibration F) (σ : Over A) : + IsPullback (homOf (pre hF.isofibration.classifier σ.hom)) (homOf Functor.Groupoidal.forget) + (homOf Functor.Groupoidal.forget) (homOf σ.hom) := by + have outer_pb := Functor.Groupoidal.isPullback (σ.hom ⋙ hF.isofibration.classifier) + have right_pb := Functor.Groupoidal.isPullback (hF.isofibration.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 pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) (σ : Over A) : + Grpd.of (∫ σ.hom ⋙ hF.isofibration.classifier) ≅ Limits.pullback σ.hom F := + (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) + +open GroupoidModel.FunctorOperation.pi in +/-- `∫ σ.hom ⋙ hF.isofibration.classifier` is the pullback of `F` along `σ`, +`∫ (isofibration_strictify hF hG).classifier` is isomorphic to `G`. +So up to isomorphism this is the hom set bijection we want. -/ +def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ + {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } where + toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ + invFun f := Over.homMk (equivInv _ f.1 f.2) + (equivInv_comp_forget ..) + left_inv f := by + ext + simp [equivInv_equivFun] + right_inv f := by + ext + simp [equivFun_equivInv] + +def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) (σ : Over A) : + { f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } ≃ + ((Over.pullback F).obj σ ⟶ Over.mk G) where + toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ + ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry + invFun f := ⟨(pullbackIsoGrothendieck hF σ).hom ≫ f.left ≫ + ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ + left_inv := sorry + right_inv := sorry + +open GroupoidModel.FunctorOperation.pi in +/-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ +def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) (σ : Over A) : + (σ ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := + calc (σ ⟶ pushforward hF hG) + _ ≃ {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // + (f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom)} := + pushforwardHomEquivAux1 .. + _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. + + + +/-- Naturality in the universal property of the pushforward. -/ +lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration 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 + sorry + + +def pushforward_isPushforward {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) where + homEquiv := pushforwardHomEquiv .. + homEquiv_comp f g := pushforwardHomEquiv_comp hF hG f g + +instance : SplitClovenIsofibration.HasPushforwards SplitClovenIsofibration := + fun F _ G => { + has_representation := ⟨pushforward F.2 G.2, ⟨pushforward_isPushforward F.2 G.2⟩⟩ } + +def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) + (G: Over B) (hG : SplitClovenIsofibration 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 isofibration. +-- (If we manage to directly define the pushforward +-- as a grothendieck construction) +theorem isIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} + (hG : SplitClovenIsofibration G) : SplitClovenIsofibration (pushforwardHom hF hG) := + sorry + +-- FIXME. For some reason needed in the proof +-- `SplitClovenIsofibration.IsStableUnderPushforward SplitClovenIsofibration` +instance SplitClovenIsofibration.RespectsIso : SplitClovenIsofibration.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. Isofibrations are stable under isomorphism (this is in mathlib, for any `rlp`) + `MorphismProperty.rlp_isMultiplicative` + `MorphismProperty.respectsIso_of_isStableUnderComposition` + 3. The chosen pushforward is an isofibration `isIsofibration_pushforward` -/ + +instance : SplitClovenIsofibration.IsStableUnderPushforward SplitClovenIsofibration 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 : SplitClovenIsofibration (pushforwardHom (F.snd) (G.snd)) := by + apply isIsofibration_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 (SplitClovenIsofibration.RespectsIso).precomp + assumption From 7891df59a91e4cbca9a95fc8a26cfbbcfc70ada6 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Tue, 7 Oct 2025 20:41:06 -0400 Subject: [PATCH 33/59] a bit progres --- .../CategoryTheory/SplitIsofibration.lean | 180 +++++++++++------- 1 file changed, 114 insertions(+), 66 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 80214363..77898fd4 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -54,7 +54,7 @@ lemma ClovenIsofibration.map_liftIso' {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} F.map (I.liftIso f hX') = eqToHom hX' ≫ f ≫ eqToHom (by simp[obj_liftObj]) := by simp[← map_liftIso I f hX'] -lemma ClovenIsofibration.liftObjComp_aux {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} +lemma ClovenIsofibration.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 @@ -63,16 +63,17 @@ end structure SplitClovenIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] (F : C ⥤ D) extends ClovenIsofibration F where - liftObjId {X : D} {X' : C} (hX' : F.obj X' = X) : liftObj (𝟙 X) hX' = X' - liftIsoId {X : D} {X' : C} (hX' : F.obj X' = X) : liftIso (𝟙 X) hX' = eqToHom (liftObjId hX').symm - liftObjComp {X Y Z : D} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : C} (hX' : F.obj X' = X) - (Y' : C) (hY' : liftObj f hX' = Y') : liftObj (f ≫ g) hX' = liftObj g (X' := Y') - (toClovenIsofibration.liftObjComp_aux f hX' Y' hY') - liftIsoComp {X Y Z : D} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [IsIso g] {X' : C} (hX' : F.obj X' = X) - (Y' : C) (hY' : liftObj f hX' = Y') : liftIso (f ≫ g) hX' = liftIso f hX' ≫ - eqToHom hY' ≫ - liftIso g (X' := Y') (toClovenIsofibration.liftObjComp_aux f hX' Y' hY') ≫ - eqToHom (liftObjComp f g hX' Y' hY').symm + liftObj_id {X : D} {X' : C} (hX' : F.obj X' = X) : liftObj (𝟙 X) hX' = X' + liftIso_id {X : D} {X' : C} (hX' : F.obj X' = X) : 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' : liftObj f hX' = Y') : liftObj (f ≫ g) hX' = + liftObj g (X' := Y') (toClovenIsofibration.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' : liftObj f hX' = Y') : liftIso (f ≫ g) hX' = + liftIso f hX' ≫ eqToHom hY' ≫ + liftIso g (X' := Y') (toClovenIsofibration.liftObj_comp_aux f hX' Y' hY') ≫ + eqToHom (liftObj_comp f g hX' Y' hY').symm namespace SplitClovenIsofibration @@ -89,17 +90,20 @@ def classifier.map.obj {X Y : Γ} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := apply @IsHomLift.codomain_eq (f := f) (φ := I.liftIso (X' := a.1) f a.2) ⟩ lemma classifier.fac' {X} {a b : F.Fiber X} (m : a ⟶ b) : - F.map m.1 = eqToHom (by rw [a.2, b.2]) := by - rw [@IsHomLift.fac' _ _ _ _ F _ _ _ _ (𝟙 X) _ m.2] + F.map (Fiber.fiberInclusion.map m) = + eqToHom (by simp [Fiber.fiberInclusion, a.2, b.2]) := by + erw [@IsHomLift.fac' _ _ _ _ F _ _ _ _ (𝟙 X) _ m.2] simp + + 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 ≫ m.1 ≫ i2 + let i := Groupoid.inv i1 ≫ Fiber.fiberInclusion.map m ≫ i2 have e :𝟙 Y = eqToHom (by simp[obj_liftObj]) ≫ - F.map (CategoryTheory.inv i1 ≫ m.1 ≫ i2) ≫ eqToHom (by simp[obj_liftObj]) + F.map (CategoryTheory.inv i1 ≫ Fiber.fiberInclusion.map m ≫ i2) ≫ eqToHom (by simp[obj_liftObj]) := by simp[i1, i2, classifier.fac', Functor.map_inv,map_liftIso'] have : F.IsHomLift (𝟙 Y) i := by @@ -109,19 +113,35 @@ def classifier.map.map {X Y} (f: X ⟶ Y) {a b : F.Fiber X} (m : a ⟶ b) : simp Fiber.homMk F _ i +-- 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 ≫ m.1 ≫ i2 +-- have e :𝟙 Y = eqToHom (by simp[obj_liftObj]) ≫ +-- F.map (CategoryTheory.inv i1 ≫ m.1 ≫ i2) ≫ eqToHom (by simp[obj_liftObj]) +-- := by +-- simp[i1, i2, classifier.fac', 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[classifier.map.map] simp[Fiber.fiberInclusion] - simp[CategoryStruct.id] + --simp[CategoryStruct.id] simp[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] - simp[CategoryStruct.comp] + --simp[CategoryStruct.comp] @[simps] def classifier.map {X Y} (f : X ⟶ Y) : F.Fiber X ⥤ F.Fiber Y where @@ -134,28 +154,28 @@ lemma classifier.map_id (X : Γ) : classifier.map I (𝟙 X) = 𝟙 (Grpd.of (F. fapply Functor.ext · intro a apply Subtype.ext - simp [map.obj, I.liftObjId] + simp [map.obj, I.liftObj_id] · intro a b f simp ext - simp [map.map, I.liftIsoId, eqToHom_map, Grpd.id_eq_id, ← heq_eq_eq] - rfl + simp [map.map, I.liftIso_id, eqToHom_map, Grpd.id_eq_id, ← heq_eq_eq] + --rfl 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, I.liftObjComp] + simp[map.obj, I.liftObj_comp] · intro a b f simp ext simp [map.map, eqToHom_map, Grpd.id_eq_id, ← heq_eq_eq,← Category.assoc] - simp[I.liftIsoComp,← Category.assoc] - congr 1 - simp[Category.assoc] - congr - simp[] + simp[I.liftIso_comp,← Category.assoc] + --congr 1 + --simp[Category.assoc] + --congr + -- simp[] @@ -235,15 +255,15 @@ def grothendieckClassifierIso.hom.map' {p1 p2: ∫ I.classifier} (h: p1 ⟶ p2) lemma grothendieckClassifierIso.hom.map_id (X : ∫ I.classifier) : hom.map I (𝟙 X) = 𝟙 _ := by convert_to _ ≫ _ ≫ Fiber.fiberInclusion.map (Hom.fiber (𝟙 X)) = _ - simp [liftIsoId, eqToHom_map] + simp [liftIso_id, eqToHom_map] --convert_to - -- rw! (castMode := .all) [Grpd.id_eq_id,hom.map_aux,liftObjId] + -- rw! (castMode := .all) [Grpd.id_eq_id,hom.map_aux,liftObj_id] 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', liftIsoComp, eqToHom_map, classifier, classifier.map.map] - rfl + simp [map', liftIso_comp, eqToHom_map, classifier, classifier.map.map] + --rfl --convert_to _ ≫ _ ≫ Fiber.fiberInclusion.map (Hom.fiber (𝟙 X)) = _ -- simp [map', liftIsoComp] @@ -274,8 +294,8 @@ def grothendieckClassifierIso.hom'.hom {X Y} (f : X ⟶ Y) def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E := Groupoidal.functorFrom (fun x => Fiber.fiberInclusion) (grothendieckClassifierIso.hom'.hom I) - (by intro X; ext;simp[hom'.hom,liftIsoId]) - (by intro X Y Z f g; ext; simp[hom'.hom,liftIsoComp]) + (by intro X; ext;simp[hom'.hom,liftIso_id]) + (by intro X Y Z f g; ext; simp[hom'.hom,liftIso_comp]) -- def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E where -- obj p := p.fiber.1 @@ -285,22 +305,59 @@ def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E := def grothendieckClassifierIso.inv.fibMap {X Y}(f : X ⟶ Y) : ((F ⋙ I.classifier).map f).obj ⟨X,rfl⟩ ⟶ ⟨Y, rfl⟩ := by - simp[classifier] - -- exact (Fiber.homMk sorry sorry sorry) - --apply (I.liftIso f ..).inv - sorry + -- simp[classifier,classifier.map.obj] + 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'] + def grothendieckClassifierIso.inv : E ⥤ ∫ I.classifier := Groupoidal.functorTo F (fun x => ⟨x, rfl⟩) (fun f => grothendieckClassifierIso.inv.fibMap I f) - sorry sorry + (fun x => by + apply Fiber.hom_ext + simp [inv.fibMap] + rw![Functor.map_id,liftIso_id] + simp[inv_eqToHom,eqToHom_map]) + (by + intro x y z f g + simp[inv.fibMap] + apply Fiber.hom_ext + rw![Functor.map_comp] + simp[liftIso_comp] + simp[eqToHom_map,classifier,classifier.map.map] + ) def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where hom := grothendieckClassifierIso.hom .. inv := grothendieckClassifierIso.inv .. - hom_inv_id := sorry + hom_inv_id := by + fapply ext + · intro p + simp[grothendieckClassifierIso.hom,grothendieckClassifierIso.inv] + fapply CategoryTheory.Functor.Groupoidal.hext + · rw[functorTo_obj_base] + · apply grothendieckClassifierIso.hom.map_aux2 + intro x y z f g + simp[grothendieckClassifierIso.inv.fibMap,classifier,classifier.map.map] + rw![Functor.map_comp] + simp[Fiber.homMk,liftIso_comp] + ext + simp[Fiber.fiberInclusion] + congr + + + --rw![liftIso_comp] + + sorry + sorry + sorry inv_hom_id := sorry @@ -309,24 +366,15 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where def id.liftObj {A : Type u} [Category.{v} A] {X Y} (f : X ⟶ Y) [IsIso f] {X' : A} (e : (𝟭 A).obj X' = X) : A := X -def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : - SplitClovenIsofibration 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) - liftObjId h := by simp [← h, ← Functor.comp_obj] - liftIsoId := by simp - liftObjComp := by simp - liftIsoComp := by simp - def id {A : Type u} [Category.{v} A] : - SplitClovenIsofibration (𝟭 A) := - iso <| Functor.Iso.refl _ + SplitClovenIsofibration (𝟭 A) where + liftObj := id.liftObj + liftIso := sorry + isHomLift := sorry + liftObj_id := sorry + liftIso_id := sorry + liftObj_comp := sorry + liftIso_comp := sorry /-- `IsMultiplicative` 1/2 -/ def comp {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} @@ -335,10 +383,10 @@ def comp {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F liftObj := sorry liftIso := sorry isHomLift := sorry - liftObjId := sorry - liftIsoId := sorry - liftObjComp := sorry - liftIsoComp := sorry + liftObj_id := sorry + liftIso_id := sorry + liftObj_comp := sorry + liftIso_comp := sorry /-- `IsStableUnderBaseChange` -/ def ofIsPullback {A B A' B' : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} A'] @@ -348,10 +396,10 @@ def ofIsPullback {A B A' B' : Type u} [Category.{v} A] [Category.{v} B] [Categor liftObj := sorry liftIso := sorry isHomLift := sorry - liftObjId := sorry - liftIsoId := sorry - liftObjComp := sorry - liftIsoComp := sorry + liftObj_id := sorry + liftIso_id := sorry + liftObj_comp := sorry + liftIso_comp := sorry -- 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) @@ -360,9 +408,9 @@ def ofIsPullback {A B A' B' : Type u} [Category.{v} A] [Category.{v} B] [Categor -- liftObj := sorry -- liftIso := sorry -- isHomLift := sorry --- liftObjId := sorry --- liftIsoId := sorry --- liftObjComp := sorry +-- liftObj_id := sorry +-- liftIso_id := sorry +-- liftObj_comp := sorry -- liftIsoComp := sorry #exit From f9429dcf4bb58a6de1a1b3cbec129c204933acbe Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 7 Oct 2025 20:58:31 -0400 Subject: [PATCH 34/59] merge pull --- .../CategoryTheory/SplitIsofibration.lean | 37 +++++---- .../Groupoids/SplitClovenIsofibration.lean | 81 ++++++++++--------- HoTTLean/Groupoids/StructuredModel.lean | 2 +- .../Groupoids => attic}/IsIsofibration.lean | 0 .../Groupoids => attic}/IsIsofibration1.lean | 0 5 files changed, 66 insertions(+), 54 deletions(-) rename {HoTTLean/Groupoids => attic}/IsIsofibration.lean (100%) rename {HoTTLean/Groupoids => attic}/IsIsofibration1.lean (100%) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 77898fd4..b1087114 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -50,8 +50,9 @@ lemma ClovenIsofibration.map_liftIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} symm apply IsHomLift.fac -lemma ClovenIsofibration.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 +lemma ClovenIsofibration.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'] lemma ClovenIsofibration.liftObj_comp_aux {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} @@ -360,21 +361,23 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where sorry inv_hom_id := sorry - - -/-- `IsMultiplicative` 1/2 -/ -def id.liftObj {A : Type u} [Category.{v} A] {X Y} - (f : X ⟶ Y) [IsIso f] {X' : A} (e : (𝟭 A).obj X' = X) : A := X - -def id {A : Type u} [Category.{v} A] : - SplitClovenIsofibration (𝟭 A) where - liftObj := id.liftObj - liftIso := sorry - isHomLift := sorry - liftObj_id := sorry - liftIso_id := sorry - liftObj_comp := sorry - liftIso_comp := sorry +def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : + SplitClovenIsofibration 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) + liftObj_id h := by simp [← h, ← Functor.comp_obj] + liftIso_id := by simp + liftObj_comp := by simp + liftIso_comp := by simp + +def id {A : Type u} [Category.{v} A] : SplitClovenIsofibration (𝟭 A) := + iso (Functor.Iso.refl _) /-- `IsMultiplicative` 1/2 -/ def comp {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} diff --git a/HoTTLean/Groupoids/SplitClovenIsofibration.lean b/HoTTLean/Groupoids/SplitClovenIsofibration.lean index 82c3e40a..2c82f4d5 100644 --- a/HoTTLean/Groupoids/SplitClovenIsofibration.lean +++ b/HoTTLean/Groupoids/SplitClovenIsofibration.lean @@ -82,6 +82,10 @@ now as objects in `Grpd`. -/ def grothendieckClassifierIso : Grpd.of (∫ hF.splitClovenIsofibration.classifier) ≅ B := Grpd.mkIso (Functor.SplitClovenIsofibration.grothendieckClassifierIso ..) +lemma grothendieckClassifierIso_inv_comp_forget : + hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := + sorry + end SplitClovenIsofibration instance : SplitClovenIsofibration.IsStableUnderBaseChange.{u,u} where @@ -94,34 +98,35 @@ instance : SplitClovenIsofibration.IsMultiplicative where comp_mem _ _ hF hG := ⟨ Functor.SplitClovenIsofibration.comp hF.splitClovenIsofibration hG.splitClovenIsofibration ⟩ - -- infer_instance +instance : SplitClovenIsofibration.RespectsIso := + MorphismProperty.respectsIso_of_isStableUnderComposition (fun X Y F hF => + ⟨ Functor.SplitClovenIsofibration.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] }⟩) -instance : SplitClovenIsofibration.HasObjects := by - sorry +instance : SplitClovenIsofibration.HasObjects where + obj_mem F G := sorry section -attribute [local instance] Grpd.SplitClovenIsofibration.isofibration - -open Functor.Isofibration +open Functor.SplitClovenIsofibration def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) (G : C ⟶ B) : - C ⟶ Grpd.of (∫ classifier (hF.isofibration)) := + C ⟶ Grpd.of (∫ classifier (hF.splitClovenIsofibration)) := G ≫ hF.grothendieckClassifierIso.inv -def isIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) : SplitClovenIsofibration (strictify hF G) := sorry - -def isofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) : (strictify hF G).Isofibration := sorry +def splitClovenIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) + {G : C ⟶ B} (hG : SplitClovenIsofibration G) : (strictify hF G).SplitClovenIsofibration := sorry /-- 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 : SplitClovenIsofibration F) {G : C ⟶ B} (hG : SplitClovenIsofibration G) : Grpd := - Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.isofibration.classifier) - (classifier (isofibration_strictify hF hG))) + Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.splitClovenIsofibration.classifier) + (classifier (splitClovenIsofibration_strictify hF hG))) /-- The morphism part (a functor) of the pushforward along `F`, of `G`. This is defined as the forgetful functor from the Grothendieck construction. -/ @@ -148,10 +153,11 @@ lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) ( (by simp) lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) (σ : Over A) : - IsPullback (homOf (pre hF.isofibration.classifier σ.hom)) (homOf Functor.Groupoidal.forget) + IsPullback (homOf (pre hF.splitClovenIsofibration.classifier σ.hom)) + (homOf Functor.Groupoidal.forget) (homOf Functor.Groupoidal.forget) (homOf σ.hom) := by - have outer_pb := Functor.Groupoidal.isPullback (σ.hom ⋙ hF.isofibration.classifier) - have right_pb := Functor.Groupoidal.isPullback (hF.isofibration.classifier) + have outer_pb := Functor.Groupoidal.isPullback (σ.hom ⋙ hF.splitClovenIsofibration.classifier) + have right_pb := Functor.Groupoidal.isPullback (hF.splitClovenIsofibration.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 @@ -170,18 +176,19 @@ lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitClovenIsofibratio The two versions of the pullback are isomorphic. -/ def pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) (σ : Over A) : - Grpd.of (∫ σ.hom ⋙ hF.isofibration.classifier) ≅ Limits.pullback σ.hom F := + Grpd.of (∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier) ≅ Limits.pullback σ.hom F := (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) open GroupoidModel.FunctorOperation.pi in -/-- `∫ σ.hom ⋙ hF.isofibration.classifier` is the pullback of `F` along `σ`, -`∫ (isofibration_strictify hF hG).classifier` is isomorphic to `G`. +/-- `∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier` is the pullback of `F` along `σ`, +`∫ (splitClovenIsofibration_strictify hF hG).classifier` is isomorphic to `G`. So up to isomorphism this is the hom set bijection we want. -/ def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} (hG : SplitClovenIsofibration G) (σ : Over A) : (σ ⟶ pushforward hF hG) ≃ - {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // - f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } where + {f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ + ∫ (splitClovenIsofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.splitClovenIsofibration.classifier σ.hom } where toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ invFun f := Over.homMk (equivInv _ f.1 f.2) (equivInv_comp_forget ..) @@ -194,13 +201,14 @@ def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} (hG : SplitClovenIsofibration G) (σ : Over A) : - { f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // - f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } ≃ + { f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ + ∫ (splitClovenIsofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.splitClovenIsofibration.classifier σ.hom } ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) where toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ - ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry - invFun f := ⟨(pullbackIsoGrothendieck hF σ).hom ≫ f.left ≫ - ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ + ((splitClovenIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry + invFun f := ⟨ (pullbackIsoGrothendieck hF σ).hom ⋙ f.left ⋙ + ((splitClovenIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ left_inv := sorry right_inv := sorry @@ -210,13 +218,13 @@ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) { (hG : SplitClovenIsofibration G) (σ : Over A) : (σ ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := calc (σ ⟶ pushforward hF hG) - _ ≃ {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // - (f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom)} := + _ ≃ {f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ + ∫ (splitClovenIsofibration_strictify hF hG).classifier // + (f ⋙ Functor.Groupoidal.forget = pre hF.splitClovenIsofibration.classifier σ.hom)} := pushforwardHomEquivAux1 .. _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. - /-- Naturality in the universal property of the pushforward. -/ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} (hG : SplitClovenIsofibration G) @@ -246,11 +254,12 @@ def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitClovenIsofibra homEquiv_comp f g := by apply pushforwardHomEquiv_comp .. } ) --- This should follow from `Groupoidal.forget` being an isofibration. +-- This should follow from `Groupoidal.forget` being an splitClovenIsofibration. -- (If we manage to directly define the pushforward -- as a grothendieck construction) -theorem isIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) : SplitClovenIsofibration (pushforwardHom hF hG) := +theorem splitClovenIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) + {G : C ⟶ B} (hG : SplitClovenIsofibration G) : + SplitClovenIsofibration (pushforwardHom hF hG) := sorry -- FIXME. For some reason needed in the proof @@ -264,10 +273,10 @@ instance SplitClovenIsofibration.RespectsIso : SplitClovenIsofibration.RespectsI `(F.op ⋙ yoneda.obj X).IsRepresentable` and `(F.op ⋙ yoneda.obj Y).IsRepresentable` implies `X ≅ Y`. - 2. Isofibrations are stable under isomorphism (this is in mathlib, for any `rlp`) + 2. SplitClovenIsofibrations are stable under isomorphism (this is in mathlib, for any `rlp`) `MorphismProperty.rlp_isMultiplicative` `MorphismProperty.respectsIso_of_isStableUnderComposition` - 3. The chosen pushforward is an isofibration `isIsofibration_pushforward` -/ + 3. The chosen pushforward is an splitClovenIsofibration `splitClovenIsofibration_pushforward` -/ instance : SplitClovenIsofibration.IsStableUnderPushforward SplitClovenIsofibration where of_isPushforward F G P := by @@ -275,7 +284,7 @@ instance : SplitClovenIsofibration.IsStableUnderPushforward SplitClovenIsofibrat 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 : SplitClovenIsofibration (pushforwardHom (F.snd) (G.snd)) := by - apply isIsofibration_pushforward + apply splitClovenIsofibration_pushforward have e : P = (p.hom).left ≫ (pushforwardHom (F.snd) (G.snd)) := by have ee := Over.w p.hom simp at ee diff --git a/HoTTLean/Groupoids/StructuredModel.lean b/HoTTLean/Groupoids/StructuredModel.lean index 990deddf..9e35d40f 100644 --- a/HoTTLean/Groupoids/StructuredModel.lean +++ b/HoTTLean/Groupoids/StructuredModel.lean @@ -1,4 +1,4 @@ -import HoTTLean.Groupoids.IsIsofibration +import HoTTLean.Groupoids.SplitClovenIsofibration /-! Here we construct universes for the groupoid natural model. diff --git a/HoTTLean/Groupoids/IsIsofibration.lean b/attic/IsIsofibration.lean similarity index 100% rename from HoTTLean/Groupoids/IsIsofibration.lean rename to attic/IsIsofibration.lean diff --git a/HoTTLean/Groupoids/IsIsofibration1.lean b/attic/IsIsofibration1.lean similarity index 100% rename from HoTTLean/Groupoids/IsIsofibration1.lean rename to attic/IsIsofibration1.lean From 17fbfbe2e56697b293ffd0f5221aa2ab94485269 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Tue, 7 Oct 2025 21:01:24 -0400 Subject: [PATCH 35/59] tidy up --- HoTTLean/Groupoids/StructuredModel.lean | 6 +++--- {HoTTLean/Groupoids => attic}/UHom.lean | 0 2 files changed, 3 insertions(+), 3 deletions(-) rename {HoTTLean/Groupoids => attic}/UHom.lean (100%) diff --git a/HoTTLean/Groupoids/StructuredModel.lean b/HoTTLean/Groupoids/StructuredModel.lean index 9e35d40f..cd1904cf 100644 --- a/HoTTLean/Groupoids/StructuredModel.lean +++ b/HoTTLean/Groupoids/StructuredModel.lean @@ -18,7 +18,7 @@ open U The π-clan we use is the set of groupoid isofibrations. -/ @[simps!] -def StructuredU : StructuredUniverse Grpd.IsIsofibration where +def StructuredU : StructuredUniverse Grpd.SplitClovenIsofibration where __ := U morphismProperty := sorry @@ -26,7 +26,7 @@ namespace U open MonoidalCategory -def liftSeqObjs (i : Nat) (h : i < 4) : StructuredUniverse Grpd.IsIsofibration.{5} := +def liftSeqObjs (i : Nat) (h : i < 4) : StructuredUniverse Grpd.SplitClovenIsofibration.{5} := match i with | 0 => StructuredU.{0,4} | 1 => StructuredU.{1,4} @@ -55,7 +55,7 @@ def liftSeqHomSucc' (i : Nat) (h : i < 3) : The groupoid natural model with three nested representable universes within the ambient natural model. -/ -def liftSeq : UHomSeq Grpd.IsIsofibration.{5} where +def liftSeq : UHomSeq Grpd.SplitClovenIsofibration.{5} where length := 3 objs := liftSeqObjs homSucc' := liftSeqHomSucc' diff --git a/HoTTLean/Groupoids/UHom.lean b/attic/UHom.lean similarity index 100% rename from HoTTLean/Groupoids/UHom.lean rename to attic/UHom.lean From 5706207a3dae6f21c2830e09913d531b5854d316 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 9 Oct 2025 11:45:20 -0400 Subject: [PATCH 36/59] splitisofib prog --- .../ForMathlib/CategoryTheory/SplitIsofibration.lean | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index b1087114..e6e54ab1 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -350,13 +350,17 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where rw![Functor.map_comp] simp[Fiber.homMk,liftIso_comp] ext - simp[Fiber.fiberInclusion] + simp[eqToHom_map] congr + rw![functorTo_obj_fiber] + · simp + simp[grothendieckClassifierIso.inv.fibMap,classifier] - --rw![liftIso_comp] - + --fapply CategoryTheory.Functor.Groupoidal.hext + --simp[eqToHom_map] sorry + sorry sorry inv_hom_id := sorry From a5a33d3a5b0c9726cd006ab63fceb6d381ab4515 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 9 Oct 2025 11:42:43 -0400 Subject: [PATCH 37/59] SplitIsofib prog --- .../Bicategory/Grothendieck.lean | 8 ++ .../CategoryTheory/SplitIsofibration.lean | 97 +++++++++++-------- HoTTLean/Grothendieck/Groupoidal/Basic.lean | 4 + 3 files changed, 70 insertions(+), 39 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index 97ff0655..d2e92987 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean @@ -370,6 +370,14 @@ attribute [local simp] eqToHom_map variable {F} +lemma ext {x y : ∫ F} (hbase : x.base = y.base) + (hfiber : (F.map (eqToHom hbase)).obj x.fiber = y.fiber) : x = y := by + cases x; cases y + congr + · simp only [eqToHom_map] at hbase hfiber + subst hbase + simp [← hfiber] + /-- A morphism in the Grothendieck category `F : C ⥤ Cat` consists of `base : X.base ⟶ Y.base` and `f.fiber : (F.map base).obj X.fiber ⟶ Y.fiber`. -/ diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index e6e54ab1..5c2f7264 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -298,6 +298,11 @@ def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E := (by intro X; ext;simp[hom'.hom,liftIso_id]) (by intro X Y Z f g; ext; simp[hom'.hom,liftIso_comp]) +lemma grothendieckClassifierIso.hom_comp_self : hom I ⋙ F = Groupoidal.forget := by + + #check functorFrom_ext + sorry + -- def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E where -- obj p := p.fiber.1 -- map := grothendieckClassifierIso.hom.map I @@ -315,54 +320,68 @@ def grothendieckClassifierIso.inv.fibMap {X Y}(f : X ⟶ Y) : · 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 [inv.fibMap] + 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[inv.fibMap] + apply Fiber.hom_ext + rw![Functor.map_comp] + simp[liftIso_comp] + simp[eqToHom_map,classifier,classifier.map.map] def grothendieckClassifierIso.inv : E ⥤ ∫ I.classifier := Groupoidal.functorTo F (fun x => ⟨x, rfl⟩) - (fun f => grothendieckClassifierIso.inv.fibMap I f) - (fun x => by - apply Fiber.hom_ext - simp [inv.fibMap] - rw![Functor.map_id,liftIso_id] - simp[inv_eqToHom,eqToHom_map]) - (by - intro x y z f g - simp[inv.fibMap] - apply Fiber.hom_ext - rw![Functor.map_comp] - simp[liftIso_comp] - simp[eqToHom_map,classifier,classifier.map.map] - ) + (fun f => inv.fibMap I f) + (fun x => inv.fibMap_id I x) + (fun f g => inv.fibMap_comp I f g) +lemma grothendieckClassifierIso.inv_comp_forget : grothendieckClassifierIso.inv I ⋙ + Groupoidal.forget = F := + Groupoidal.functorTo_forget def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where hom := grothendieckClassifierIso.hom .. inv := grothendieckClassifierIso.inv .. hom_inv_id := by - fapply ext - · intro p - simp[grothendieckClassifierIso.hom,grothendieckClassifierIso.inv] - fapply CategoryTheory.Functor.Groupoidal.hext - · rw[functorTo_obj_base] - · apply grothendieckClassifierIso.hom.map_aux2 - intro x y z f g - simp[grothendieckClassifierIso.inv.fibMap,classifier,classifier.map.map] - rw![Functor.map_comp] - simp[Fiber.homMk,liftIso_comp] - ext - simp[eqToHom_map] - congr - - rw![functorTo_obj_fiber] - · simp - simp[grothendieckClassifierIso.inv.fibMap,classifier] - - --fapply CategoryTheory.Functor.Groupoidal.hext - --simp[eqToHom_map] - sorry - - sorry - sorry + fapply Functor.Groupoidal.FunctorTo.hext + · simp [Functor.assoc, grothendieckClassifierIso.inv_comp_forget,grothendieckClassifierIso.hom_comp_self] + · sorry + · sorry +-- fapply ext + -- · intro p + -- simp[grothendieckClassifierIso.hom,grothendieckClassifierIso.inv] +-- fapply CategoryTheory.Functor.Groupoidal.ext +-- · rw[functorTo_obj_base] +-- · apply grothendieckClassifierIso.hom.map_aux2 +-- · intro x y z f g +-- simp[grothendieckClassifierIso.inv.fibMap,classifier,classifier.map.map] +-- rw![Functor.map_comp] +-- simp[Fiber.homMk,liftIso_comp] +-- ext +-- simp[eqToHom_map] +-- congr +-- · rw![functorTo_obj_fiber] +-- · simp +-- simp[grothendieckClassifierIso.inv.fibMap,classifier, classifier.map.obj] +-- rw![grothendieckClassifierIso.hom.map_aux2] +-- rw! (castMode := .all) [functorTo_obj_base] +-- --F.obj (I.liftObj (eqToHom ⋯) ⋯) = p.base +-- --apply Fiber.hom_ext +-- --fapply CategoryTheory.Functor.Groupoidal.hext +-- --simp[eqToHom_map] +-- sorry + +-- · sorry + + inv_hom_id := sorry def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index 11d00434..bd49e93c 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -288,6 +288,10 @@ variable {F} section ext +theorem ext {x y : ∫ F} (hbase : x.base = y.base) + (hfiber : (F.map (eqToHom hbase)).obj x.fiber = y.fiber) : x = y := by + apply Functor.Grothendieck.ext hbase hfiber + theorem hext {x y : ∫ F} (hbase : x.base = y.base) (hfiber : HEq x.fiber y.fiber) : x = y := by rcases x with ⟨xbase, xfiber⟩ subst hbase From 9b9231ebce70dbe30caa04550230eb3b667702ba Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 9 Oct 2025 18:13:04 -0400 Subject: [PATCH 38/59] problem on line 515 --- .../CategoryTheory/SplitIsofibration.lean | 149 ++++++++++++++++-- 1 file changed, 139 insertions(+), 10 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 5c2f7264..4f9b2b8d 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -32,10 +32,18 @@ structure ClovenIsofibration (F : C ⥤ D) where 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') + + + section variable {F : C ⥤ D} (I : ClovenIsofibration F) +-- instance liftIso_IsIso (F : C ⥤ D) {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : +-- IsIso (I.liftIso f hX') := sorry + 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' @@ -76,6 +84,11 @@ structure SplitClovenIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] liftIso g (X' := Y') (toClovenIsofibration.liftObj_comp_aux f hX' Y' hY') ≫ eqToHom (liftObj_comp f g hX' Y' hY').symm + +-- lemma liftObj_codomain (F : C ⥤ D) {X Y Z: D} (f: X ⟶ Y) [IsIso f] {X': C} (hX': F.obj X' = X) (e: Y = Z): +-- I.liftObj f hX' = + + namespace SplitClovenIsofibration open ClovenIsofibration @@ -83,6 +96,9 @@ open ClovenIsofibration variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} (I : SplitClovenIsofibration F) + + + /-- Any isofibration `F : E ⥤ Γ` of groupoids is classified by a functor `classifier : Γ ⥤ Grpd`. -/ def classifier.map.obj {X Y : Γ} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := @@ -229,7 +245,7 @@ p1.fiber : F.Fiber p1.base F.obj p1.fiber = p1.base -/ - +#check Functor.ext lemma grothendieckClassifierIso.hom.map_aux2 (X: Γ) (a: I.classifier.obj X) : F.obj a.1 = X := by simp[classifier] at a @@ -347,14 +363,66 @@ lemma grothendieckClassifierIso.inv_comp_forget : grothendieckClassifierIso.inv Groupoidal.forget = F := Groupoidal.functorTo_forget + +lemma Fiber.fiberInclusion.obj.fiber (p : ∫ I.classifier): + F.obj (Fiber.fiberInclusion.obj p.fiber) = p.base := by + apply grothendieckClassifierIso.hom.map_aux2 + +-- lemma Fiber.hext {x y} {a: F.Fiber x} {b: F.Fiber y} +-- (hbase: x = y) +-- (hfib : +-- Fiber.fiberInclusion.obj b = + +-- (F.map (eqToHom hbase)).obj sorry ) : a ≍ b := sorry + +#check Fiber.hom_ext + + +lemma hom_hext {x : Γ } {a b : Fiber F x} (φ ψ : a ⟶ b) + (h : Fiber.fiberInclusion.map φ = Fiber.fiberInclusion.map ψ) : φ ≍ ψ := sorry + --Subtype.ext h + def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where hom := grothendieckClassifierIso.hom .. inv := grothendieckClassifierIso.inv .. hom_inv_id := by fapply Functor.Groupoidal.FunctorTo.hext · simp [Functor.assoc, grothendieckClassifierIso.inv_comp_forget,grothendieckClassifierIso.hom_comp_self] - · sorry - · sorry + · intro p + simp[grothendieckClassifierIso.inv] + simp[grothendieckClassifierIso.hom] + rw[Subtype.heq_iff_coe_eq] + · simp;rfl + · intro + simp + rw[Fiber.fiberInclusion.obj.fiber] + · intro x y f + simp + /- (I.classifier.map (Hom.base f)).obj x.fiber ⟶ y.fiber : ↑(I.classifier.obj y.base) + in E + f : x ⟶ y + + + -/ + congr + · simp[grothendieckClassifierIso.inv,grothendieckClassifierIso.hom ] + apply Functor.Groupoidal.ext + · simp[classifier,classifier.map.obj] + + sorry + sorry + · sorry + · apply Functor.Groupoidal.Hom.hext' sorry sorry sorry + · simp[grothendieckClassifierIso.inv,grothendieckClassifierIso.hom] + simp[grothendieckClassifierIso.hom'.hom,← Functor.map_comp] + sorry + · sorry + -- apply hom_hext + -- simp[grothendieckClassifierIso.inv,grothendieckClassifierIso.hom] + -- simp[grothendieckClassifierIso.inv.fibMap] + -- apply Groupoidal.Hom.hext' + -- simp[functorFrom_map] + -- sorry -- fapply ext -- · intro p -- simp[grothendieckClassifierIso.hom,grothendieckClassifierIso.inv] @@ -398,21 +466,81 @@ def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : liftIso_id := by simp liftObj_comp := by simp liftIso_comp := by simp + liftIso_IsIso := sorry def id {A : Type u} [Category.{v} A] : SplitClovenIsofibration (𝟭 A) := iso (Functor.Iso.refl _) +section + +variables {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} + (IF : SplitClovenIsofibration F) {G : B ⥤ C} (IG : SplitClovenIsofibration G) + + +def comp.liftObj {X Y: C} (f: X ⟶ Y) [i: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) + have i0 : IsIso f1 := sorry + IF.liftObj (X' := X') f1 rfl + +def comp.liftIso {X Y: C} (f: X ⟶ Y) [i: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) + have i0 : IsIso f1 := sorry + IF.liftIso (X' := X') f1 rfl + +def comp.isHomLift {X Y: C} (f: X ⟶ Y) [i: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 + · simp[comp.liftIso] + let e := ClovenIsofibration.map_liftIso' (F := F) + rw[e] + simp[eqToHom_map] + simp[ClovenIsofibration.map_liftIso'] + rw![liftObj] + simp + · assumption + · simp[liftObj,ClovenIsofibration.obj_liftObj] + + +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] + rw![liftIso_id] + --have i: IsIso (eqToHom sorry ≫ 𝟙 _) := sorry + have h1 : eqToHom (Eq.symm (IG.liftObj_id hX')) = eqToHom (Eq.symm (IG.liftObj_id hX')) ≫ 𝟙 _ := sorry + rw![h1] + rw [liftObj_comp] + have e0 : IG.liftObj (𝟙 X) hX' = F.obj X' := sorry + rw![e0] + · + sorry + · sorry + --convert_to @liftObj _ _ _ _ _ _ _ IF _ _ (𝟙 (F.obj X')) _ = _ + · sorry + --apply liftObj_id + +-- have h : IF.liftObj (eqToHom (Eq.symm (IG.liftObj_id hX'))) rfl = X':= sorry +-- have h: IF.liftObj (eqToHom (Eq.symm (IG.liftObj_id hX')) ≫ 𝟙 (F.obj X')) (by sorry) = X' := sorry +-- simp[eqToHom] +-- sorry + + + /-- `IsMultiplicative` 1/2 -/ -def comp {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} - (IF : SplitClovenIsofibration F) {G : B ⥤ C} (IG : SplitClovenIsofibration G) : +def comp : SplitClovenIsofibration (F ⋙ G) where - liftObj := sorry - liftIso := sorry - isHomLift := sorry - liftObj_id := sorry + liftObj := comp.liftObj IF IG + liftIso := comp.liftIso IF IG + isHomLift := comp.isHomLift IF IG + liftObj_id := by + intro X X' hX' + apply comp.liftObj_id liftIso_id := sorry - liftObj_comp := sorry + liftObj_comp := by + sorry liftIso_comp := sorry + liftIso_IsIso := sorry /-- `IsStableUnderBaseChange` -/ def ofIsPullback {A B A' B' : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} A'] @@ -426,6 +554,7 @@ def ofIsPullback {A B A' B' : Type u} [Category.{v} A] [Category.{v} B] [Categor liftIso_id := sorry liftObj_comp := sorry liftIso_comp := sorry + liftIso_IsIso := sorry -- 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) From a4e5ca5f0c9e9f68a6480cdaec0fe3fc8efa8cbe Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 9 Oct 2025 11:42:14 -0400 Subject: [PATCH 39/59] implicit arguments --- HoTTLean/Model/UnstructuredModel.lean | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/HoTTLean/Model/UnstructuredModel.lean b/HoTTLean/Model/UnstructuredModel.lean index 0eb90b9d..e0fe7e19 100644 --- a/HoTTLean/Model/UnstructuredModel.lean +++ b/HoTTLean/Model/UnstructuredModel.lean @@ -243,7 +243,7 @@ structure PolymorphicPi (U0 U1 U2 : UnstructuredUniverse Ctx) where (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_tp : b ≫ U1.tp = B), Γ ⟶ U2.Tm) + (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) = From 24dbf4a164d2537c5d43f25f6962aec1b089ca82 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 9 Oct 2025 16:18:42 -0400 Subject: [PATCH 40/59] Iso --- HoTTLean/ForMathlib.lean | 149 ------------ .../Bicategory/Grothendieck.lean | 225 +++++++++++++++++- .../CategoryTheory/Functor/IsPullback.lean | 5 +- HoTTLean/ForMathlib/CategoryTheory/Grpd.lean | 1 + .../ForMathlib/CategoryTheory/NatTrans.lean | 7 + .../ForMathlib/CategoryTheory/Whiskering.lean | 9 + HoTTLean/Grothendieck/Groupoidal/Basic.lean | 135 +++++------ HoTTLean/Groupoids/Sigma.lean | 6 +- 8 files changed, 302 insertions(+), 235 deletions(-) diff --git a/HoTTLean/ForMathlib.lean b/HoTTLean/ForMathlib.lean index 110008ee..f571f07d 100644 --- a/HoTTLean/ForMathlib.lean +++ b/HoTTLean/ForMathlib.lean @@ -9,7 +9,6 @@ import Mathlib.Data.Part import Mathlib.CategoryTheory.Monoidal.Cartesian.Basic import Mathlib.CategoryTheory.Core import Mathlib.CategoryTheory.Adjunction.Limits -import HoTTLean.ForMathlib.CategoryTheory.Bicategory.Grothendieck /-! This file contains declarations missing from mathlib, to be upstreamed. -/ @@ -415,154 +414,6 @@ theorem Cat.map_id_map {A : Γ ⥤ Cat.{v₁,u₁}} end -namespace Functor.Grothendieck - -variable {Γ : Type*} [Category Γ] {A : Γ ⥤ Cat} - {x y : Grothendieck A} - -theorem cast_eq {F G : Γ ⥤ Cat} - (h : F = G) (p : Grothendieck F) : - (cast (by subst h; rfl) p : Grothendieck G) - = ⟨ p.base , cast (by subst h; rfl) p.fiber ⟩ := by - subst h - rfl - -theorem map_eqToHom_base_pf {G1 G2 : Grothendieck A} (eq : G1 = G2) : - A.obj G1.base = A.obj G2.base := by subst eq; rfl - -theorem map_eqToHom_base {G1 G2 : Grothendieck A} (eq : G1 = G2) - : A.map (eqToHom eq).base = eqToHom (map_eqToHom_base_pf eq) := by - simp [eqToHom_map] - -theorem map_eqToHom_obj_base {F G : Γ ⥤ Cat.{v,u}} (h : F = G) - (x) : ((Grothendieck.map (eqToHom h)).obj x).base = x.base := rfl - -theorem map_forget {F G : Γ ⥤ Cat.{v,u}} (α : F ⟶ G) : - Grothendieck.map α ⋙ Grothendieck.forget G = - Grothendieck.forget F := - rfl - -variable {C : Type u} [Category.{v} C] - {F : C ⥤ Cat.{v₁,u₁}} - -variable {E : Type*} [Category E] -variable (fib : ∀ c, F.obj c ⥤ E) (hom : ∀ {c c' : C} (f : c ⟶ c'), fib c ⟶ F.map f ⋙ fib c') -variable (hom_id : ∀ c, hom (𝟙 c) = eqToHom (by simp only [Functor.map_id]; rfl)) -variable (hom_comp : ∀ c₁ c₂ c₃ (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃), hom (f ≫ g) = - hom f ≫ Functor.whiskerLeft (F.map f) (hom g) ≫ eqToHom (by simp only [Functor.map_comp]; rfl)) - -variable (K : Grothendieck F ⥤ E) - -def asFunctorFrom_fib (c : C) : (F.obj c) ⥤ E := ι F c ⋙ K - -def asFunctorFrom_hom {c c' : C} (f: c ⟶ c') : - asFunctorFrom_fib K c ⟶ F.map f ⋙ asFunctorFrom_fib K c' := - Functor.whiskerRight (ιNatTrans f) K - -lemma asFunctorFrom_hom_app {c c' : C} (f: c ⟶ c') (p : F.obj c) : - (asFunctorFrom_hom K f).app p = K.map ((ιNatTrans f).app p) := - rfl - -lemma asFunctorFrom_hom_id (c : C) : asFunctorFrom_hom K (𝟙 c) = - eqToHom (by simp only[Functor.map_id,Cat.id_eq_id,Functor.id_comp]) := by - ext p - simp [asFunctorFrom_hom_app, eqToHom_map, ιNatTrans_id_app] - -lemma asFunctorFrom_hom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g: c₂ ⟶ c₃) : - asFunctorFrom_hom K (f ≫ g) = - asFunctorFrom_hom K f ≫ Functor.whiskerLeft (F.map f) (asFunctorFrom_hom K g) ≫ eqToHom - (by simp[← Functor.assoc]; congr) := by - ext p - simp [asFunctorFrom_hom, eqToHom_map, ιNatTrans_comp_app] - -theorem asFunctorFrom : Grothendieck.functorFrom (asFunctorFrom_fib K) (asFunctorFrom_hom K) - (asFunctorFrom_hom_id K) (asFunctorFrom_hom_comp K) = K := by - fapply CategoryTheory.Functor.ext - · intro X - rfl - · intro x y f - simp only [functorFrom_obj, asFunctorFrom_fib, Functor.comp_obj, functorFrom_map, - asFunctorFrom_hom, Functor.whiskerRight_app, Functor.comp_map, ← Functor.map_comp, - eqToHom_refl, Category.comp_id, Category.id_comp] - congr - fapply Hom.ext - · simp - · simp - -variable {D : Type*} [Category D] (G : E ⥤ D) - -def functorFrom_comp_fib (c : C) : F.obj c ⥤ D := fib c ⋙ G - -def functorFrom_comp_hom {c c' : C} (f : c ⟶ c') : - functorFrom_comp_fib fib G c ⟶ F.map f ⋙ functorFrom_comp_fib fib G c' := - Functor.whiskerRight (hom f) G - -include hom_id in -lemma functorFrom_comp_hom_id (c : C) : functorFrom_comp_hom fib hom G (𝟙 c) - = eqToHom (by simp [Cat.id_eq_id, Functor.id_comp]) := by - ext x - simp [hom_id, eqToHom_map, functorFrom_comp_hom] - -include hom_comp in -lemma functorFrom_comp_hom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃): - functorFrom_comp_hom fib (fun {c c'} ↦ hom) G (f ≫ g) - = functorFrom_comp_hom fib (fun {c c'} ↦ hom) G f ≫ - Functor.whiskerLeft (F.map f) (functorFrom_comp_hom fib hom G g) ≫ - eqToHom (by simp[Cat.comp_eq_comp, Functor.map_comp, Functor.assoc]) := by - ext - simp [functorFrom_comp_hom, hom_comp, eqToHom_map] - -theorem functorFrom_comp : functorFrom fib hom hom_id hom_comp ⋙ G = - functorFrom (functorFrom_comp_fib fib G) (functorFrom_comp_hom fib hom G) - (functorFrom_comp_hom_id fib hom hom_id G) - (functorFrom_comp_hom_comp fib hom hom_comp G) := by - fapply CategoryTheory.Functor.ext - · intro X - simp [functorFrom_comp_fib] - · intro x y f - simp [functorFrom_comp_hom, functorFrom_comp_fib] - -variable (fib' : ∀ c, F.obj c ⥤ E) (hom' : ∀ {c c' : C} (f : c ⟶ c'), fib' c ⟶ F.map f ⋙ fib' c') -variable (hom_id' : ∀ c, hom' (𝟙 c) = eqToHom (by simp only [Functor.map_id]; rfl)) -variable (hom_comp' : ∀ c₁ c₂ c₃ (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃), hom' (f ≫ g) = - hom' f ≫ Functor.whiskerLeft (F.map f) (hom' g) ≫ eqToHom (by simp only [Functor.map_comp]; rfl)) - -theorem functorFrom_eq_of (ef : fib = fib') - (hhom : ∀ {c c' : C} (f : c ⟶ c'), hom f ≫ eqToHom (by rw[ef]) = eqToHom (by rw[ef]) ≫ hom' f) : - functorFrom fib hom hom_id hom_comp = functorFrom fib' hom' hom_id' hom_comp' := by - subst ef - congr! - · aesop_cat - -theorem functorFrom_ext {K K' : Grothendieck F ⥤ E} - (hfib : asFunctorFrom_fib K = asFunctorFrom_fib K') - (hhom : ∀ {c c' : C} (f : c ⟶ c'), asFunctorFrom_hom K f ≫ eqToHom (by rw [hfib]) - = eqToHom (by rw[hfib]) ≫ asFunctorFrom_hom K' f) - : K = K' := - calc K - _ = functorFrom (asFunctorFrom_fib K) (asFunctorFrom_hom K) - (asFunctorFrom_hom_id K) (asFunctorFrom_hom_comp K) := - (asFunctorFrom K).symm - _ = functorFrom (asFunctorFrom_fib K') (asFunctorFrom_hom K') - (asFunctorFrom_hom_id K') (asFunctorFrom_hom_comp K') := by - apply functorFrom_eq_of - · exact hhom - · exact hfib - _ = K' := asFunctorFrom K' - -theorem functorFrom_hext {K K' : Grothendieck F ⥤ E} - (hfib : asFunctorFrom_fib K = asFunctorFrom_fib K') - (hhom : ∀ {c c' : C} (f : c ⟶ c'), asFunctorFrom_hom K f ≍ asFunctorFrom_hom K' f) - : K = K' := by - fapply functorFrom_ext - · assumption - · intros - apply eq_of_heq - simp only [heq_eqToHom_comp_iff, comp_eqToHom_heq_iff] - apply hhom - -end Functor.Grothendieck - section variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D] diff --git a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index d2e92987..4b253597 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean @@ -12,6 +12,9 @@ import Mathlib.CategoryTheory.Category.Cat.AsSmall import Mathlib.CategoryTheory.Elements import Mathlib.CategoryTheory.Comma.Over.Basic import HoTTLean.ForMathlib.CategoryTheory.Functor.Iso +import HoTTLean.ForMathlib +import HoTTLean.ForMathlib.CategoryTheory.Whiskering +import HoTTLean.ForMathlib.CategoryTheory.NatTrans /-! # The Grothendieck construction @@ -1036,7 +1039,7 @@ instance faithful_ι (c : C) : (ι F c).Faithful where injection f with _ f rwa [cancel_epi] at f -@[simp] theorem ι_comp_forget : ι F c ⋙ forget _ = (const (F.obj c)).obj c := +theorem ι_comp_forget : ι F c ⋙ forget _ = (const (F.obj c)).obj c := rfl @[simp] theorem ι_comp_pre (G : D ⥤ C) (x : D) @@ -1073,6 +1076,15 @@ lemma ιNatTrans_comp_app {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {a} : end ιNatTrans +theorem cast_eq {F G : C ⥤ Cat} + (h : F = G) (p : Grothendieck F) : + (cast (by subst h; rfl) p : Grothendieck G) + = ⟨ p.base , cast (by subst h; rfl) p.fiber ⟩ := by + subst h + rfl + +section + variable (fib : ∀ c, F.obj c ⥤ E) (hom : ∀ {c c' : C} (f : c ⟶ c'), fib c ⟶ F.map f ⋙ fib c') variable (hom_id : ∀ c, hom (𝟙 c) = eqToHom (by simp only [Functor.map_id]; rfl)) variable (hom_comp : ∀ c₁ c₂ c₃ (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃), hom (f ≫ g) = @@ -1088,11 +1100,203 @@ def functorFrom : ∫ F ⥤ E where map_id X := by simp [hom_id] map_comp f g := by simp [hom_comp] +theorem map_eqToHom_base_pf {G1 G2 : Grothendieck F} (eq : G1 = G2) : + F.obj G1.base = F.obj G2.base := by subst eq; rfl + +theorem map_eqToHom_base {G1 G2 : Grothendieck F} (eq : G1 = G2) + : F.map (eqToHom eq).base = eqToHom (map_eqToHom_base_pf eq) := by + simp [eqToHom_map] + +theorem map_eqToHom_obj_base {F G : C ⥤ Cat.{v,u}} (h : F = G) + (x) : ((Grothendieck.map (eqToHom h)).obj x).base = x.base := rfl + +theorem map_forget {F G : C ⥤ Cat.{v,u}} (α : F ⟶ G) : + Grothendieck.map α ⋙ Grothendieck.forget G = + Grothendieck.forget F := + rfl + +variable (K : Grothendieck F ⥤ E) + +abbrev asFunctorFromFib (c : C) : (F.obj c) ⥤ E := ι F c ⋙ K + +abbrev asFunctorFromHom {c c' : C} (f: c ⟶ c') : + asFunctorFromFib K c ⟶ F.map f ⋙ asFunctorFromFib K c' := + Functor.whiskerRight (ιNatTrans f) K + +lemma asFunctorFromHom_app {c c' : C} (f: c ⟶ c') (p : F.obj c) : + (asFunctorFromHom K f).app p = K.map ((ιNatTrans f).app p) := + rfl + +lemma asFunctorFromHom_id (c : C) : asFunctorFromHom K (𝟙 c) = + eqToHom (by simp only [Functor.map_id,Cat.id_eq_id,Functor.id_comp]) := by + ext p + simp [eqToHom_map, ιNatTrans_id_app] + +lemma asFunctorFromHom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g: c₂ ⟶ c₃) : + asFunctorFromHom K (f ≫ g) = + asFunctorFromHom K f ≫ Functor.whiskerLeft (F.map f) (asFunctorFromHom K g) ≫ eqToHom + (by simp[← Functor.assoc]; congr) := by + ext p + simp [asFunctorFromHom, eqToHom_map, ιNatTrans_comp_app] + +theorem asFunctorFrom : Grothendieck.functorFrom (asFunctorFromFib K) (asFunctorFromHom K) + (asFunctorFromHom_id K) (asFunctorFromHom_comp K) = K := by + fapply CategoryTheory.Functor.ext + · intro X + rfl + · intro x y f + simp only [functorFrom_obj, asFunctorFromFib, Functor.comp_obj, functorFrom_map, + asFunctorFromHom, Functor.whiskerRight_app, Functor.comp_map, ← Functor.map_comp, + eqToHom_refl, Category.comp_id, Category.id_comp] + congr + fapply Hom.ext + · simp + · simp + +section + +variable {D : Type*} [Category D] (G : E ⥤ D) + +def functorFromCompFib (c : C) : F.obj c ⥤ D := fib c ⋙ G + +def functorFromCompHom {c c' : C} (f : c ⟶ c') : + functorFromCompFib fib G c ⟶ F.map f ⋙ functorFromCompFib fib G c' := + Functor.whiskerRight (hom f) G + +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, eqToHom_map, functorFromCompHom] + +include hom_comp in +lemma functorFromCompHom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃): + functorFromCompHom fib hom G (f ≫ g) + = functorFromCompHom fib hom G f ≫ + 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, eqToHom_map] + +theorem functorFrom_comp : functorFrom fib hom hom_id hom_comp ⋙ G = + functorFrom (functorFromCompFib fib G) (functorFromCompHom fib hom G) + (functorFromCompHom_id fib hom hom_id G) + (functorFromCompHom_comp fib hom hom_comp G) := by + fapply CategoryTheory.Functor.ext + · intro X + simp [functorFromCompFib] + · intro x y f + simp [functorFromCompHom, functorFromCompFib] + +end + +section +variable (fib' : ∀ c, F.obj c ⥤ E) (hom' : ∀ {c c' : C} (f : c ⟶ c'), fib' c ⟶ F.map f ⋙ fib' c') +variable (hom_id' : ∀ c, hom' (𝟙 c) = eqToHom (by simp only [Functor.map_id]; rfl)) +variable (hom_comp' : ∀ c₁ c₂ c₃ (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃), hom' (f ≫ g) = + hom' f ≫ Functor.whiskerLeft (F.map f) (hom' g) ≫ eqToHom (by simp only [Functor.map_comp]; rfl)) + +theorem functorFrom_eq_of (ef : fib = fib') + (hhom : ∀ {c c' : C} (f : c ⟶ c'), hom f ≫ eqToHom (by rw[ef]) = eqToHom (by rw[ef]) ≫ hom' f) : + functorFrom fib hom hom_id hom_comp = functorFrom fib' hom' hom_id' hom_comp' := by + subst ef + congr! + · aesop_cat + +theorem functorFrom_ext {K K' : Grothendieck F ⥤ E} + (hfib : ∀ c, ι F c ⋙ K = ι F c ⋙ K') + (hhom : ∀ {c c' : C} (f : c ⟶ c'), Functor.whiskerRight (ιNatTrans f) K ≫ + eqToHom (by simp [Functor.assoc, hfib]) + = eqToHom (by rw[hfib]) ≫ Functor.whiskerRight (ιNatTrans f) K') : + K = K' := + calc K + _ = functorFrom (asFunctorFromFib K) (asFunctorFromHom K) + (asFunctorFromHom_id K) (asFunctorFromHom_comp K) := + (asFunctorFrom K).symm + _ = functorFrom (asFunctorFromFib K') (asFunctorFromHom K') + (asFunctorFromHom_id K') (asFunctorFromHom_comp K') := by + apply functorFrom_eq_of + · exact hhom + · ext + apply hfib + _ = K' := asFunctorFrom K' + +theorem functorFrom_hext {K K' : Grothendieck F ⥤ E} + (hfib : ∀ c, ι F c ⋙ K = ι F c ⋙ K') + (hhom : ∀ {c c' : C} (f : c ⟶ c'), Functor.whiskerRight (ιNatTrans f) K ≍ + Functor.whiskerRight (ιNatTrans f) K') + : K = K' := by + fapply functorFrom_ext + · assumption + · intros + apply eq_of_heq + simp only [heq_eqToHom_comp_iff, comp_eqToHom_heq_iff] + apply hhom + +end + /-- `Grothendieck.ι F c` composed with `Grothendieck.functorFrom` is isomorphic a functor on a fiber on `F` supplied as the first argument to `Grothendieck.functorFrom`. -/ def ιCompFunctorFrom (c : C) : ι F c ⋙ (functorFrom fib hom hom_id hom_comp) ≅ fib c := NatIso.ofComponents (fun _ => CategoryTheory.Iso.refl _) (fun f => by simp [hom_id]) +@[simp] +lemma ι_comp_functorFrom (c : C) : ι F c ⋙ (functorFrom fib hom hom_id hom_comp) = fib c := + Functor.ext_of_iso (ιCompFunctorFrom fib hom hom_id hom_comp c) (by intro; rfl) + +lemma whiskerRight_ιNatTrans_functorFrom {x y} (f : x ⟶ y) : + Functor.whiskerRight (ιNatTrans f) (functorFrom fib hom hom_id hom_comp) = + eqToHom (ι_comp_functorFrom ..) ≫ hom f ≫ + eqToHom (by rw [Functor.assoc, ι_comp_functorFrom]) := by + ext; simp + +section +variable (A : E ⥤ C) (fibObj : (x : E) → (A ⋙ F).obj x) + (fibMap : {x y : E} → (f : x ⟶ y) → ((A ⋙ F).map f).obj (fibObj x) ⟶ fibObj y) + (map_id : (x : E) → fibMap (CategoryStruct.id x) + = eqToHom (functorTo_map_id_aux A fibObj x)) + (map_comp : {x y z : E} → (f : x ⟶ y) → (g : y ⟶ z) → fibMap (f ≫ g) + = eqToHom (functorTo_map_comp_aux A fibObj f g) + ≫ (F.map (A.map g)).map (fibMap f) ≫ fibMap g) + +@[simps!] +def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget F) + (fibObj_fib_obj : ∀ {c} x, fibObj ((fib c).obj x) ≍ x) + (fibMap_fib_map : ∀ {c} {x y} (f : x ⟶ y), fibMap ((fib c).map f) ≍ f) + (fib_obj_fibObj : ∀ x, (fib (A.obj x)).obj (fibObj x) = x) + (hom_map_app_fibObj : ∀ {x y} (f : x ⟶ y), (hom (A.map f)).app (fibObj x) ≫ + (fib (A.obj y)).map (fibMap f) ≍ f) + (whiskerRight_functorTo : ∀ {x y} (f : x ⟶ y), whiskerRight (hom f) + (functorTo A fibObj fibMap map_id map_comp) ≍ ιNatTrans (F := F) f) + : ∫ F ≅≅ E where + hom := functorFrom fib hom hom_id hom_comp + inv := functorTo A fibObj fibMap map_id map_comp + hom_inv_id := by + fapply functorFrom_hext + · intro c + rw [← Functor.assoc, ι_comp_functorFrom] + apply FunctorTo.hext + · simp only [Functor.assoc, functorTo_forget, Functor.id_comp, fib_comp] + · apply fibObj_fib_obj + · intro x y f + simp only [comp_obj, functorTo_obj_base, comp_map, functorTo_map_base, functorTo_obj_fiber, + functorTo_map_fiber, id_obj, ι_obj_base, id_map, ι_map_base, ι_obj_fiber, ι_map_fiber] + rw! [eqToHom_comp_heq, heq_cast_iff_heq] + apply fibMap_fib_map + · intro c c' f + simp only [comp_whiskerRight, whiskerRight_ιNatTrans_functorFrom, whiskerRight_comp, + eqToHom_whiskerRight, id_whiskerRight, eqToHom_comp_heq_iff, comp_eqToHom_heq_iff] + apply whiskerRight_functorTo + inv_hom_id := by + fapply Functor.ext + · intro x + simp [fib_obj_fibObj] + · intro x y f + simp [← heq_eq_eq, hom_map_app_fibObj] + +end +end + end FunctorFrom /-- The fiber inclusion `ι F c` composed with `map α` is isomorphic to `α.app c ⋙ ι F' c`. -/ @@ -1102,6 +1306,9 @@ def ιCompMap {F' : C ⥤ Cat} (α : F ⟶ F') (c : C) : ι F c ⋙ map α ≅ simp only [CategoryTheory.Iso.refl_hom, Category.comp_id] apply Hom.ext <;> simp) +lemma ι_comp_map {F' : C ⥤ Cat} (α : F ⟶ F') (c : C) : ι F c ⋙ map α = α.app c ⋙ ι F' c := + Functor.ext_of_iso (ιCompMap ..) (by intro; rfl) + section AsSmall attribute [-simp] AsSmall.down_obj AsSmall.down_map @@ -1110,7 +1317,7 @@ attribute [-simp] AsSmall.down_obj AsSmall.down_map @[simp] def compAsSmallFunctorEquivalenceInverse : ∫ F ⥤ ∫(F ⋙ Cat.asSmallFunctor.{w}) := functorTo (forget _) (fun X => (AsSmall.up.obj X.fiber)) (fun f => (AsSmall.up.map f.fiber)) - (by simp) (by intros; simp; rfl) + (by simp) (by intros; simp) /-- The functor to build the equivalence `compAsSmallFunctorEquivalence`. -/ @[simp] def compAsSmallFunctorEquivalenceFunctor : @@ -1119,8 +1326,7 @@ attribute [-simp] AsSmall.down_obj AsSmall.down_map (by intros; simp; apply eqToHom_map) -- FIXME: eqToHom_map does not fire under simp (by intros - simp [Functor.map_comp] - rfl) + simp [Functor.map_comp]) -- FIXME: these AsSmall goals are awful. Need to add some evil lemmas for AsSmall.up, AsSmall.down /-- Taking the Grothendieck construction on `F ⋙ asSmallFunctor`, where @@ -1146,16 +1352,13 @@ namespace AsSmall AsSmall.up.map (AsSmall.down.map f) = f := rfl theorem comp_up_inj {C : Type u} [Category.{v} C] - {D : Type u₁} [Category.{v₁} D] - {F G : C ⥤ D} - (h : F ⋙ (AsSmall.up : D ⥤ AsSmall.{w} D) = - G ⋙ AsSmall.up) - : F = G := by + {D : Type u₁} [Category.{v₁} D] {F G : C ⥤ D} + (h : F ⋙ (AsSmall.up : D ⥤ AsSmall.{w} D) = G ⋙ AsSmall.up) : F = G := by convert_to F ⋙ (AsSmall.up : D ⥤ AsSmall.{w} D) ⋙ AsSmall.down = G ⋙ (AsSmall.up : D ⥤ AsSmall.{w} D) ⋙ AsSmall.down - simp [← Functor.assoc, h] + rw [← Functor.assoc, h, Functor.assoc] theorem comp_down_inj {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] @@ -1165,7 +1368,7 @@ theorem comp_down_inj {C : Type u} [Category.{v} C] convert_to F ⋙ AsSmall.down ⋙ AsSmall.up = G ⋙ AsSmall.down ⋙ AsSmall.up - simp [← Functor.assoc, h] + rw [← Functor.assoc, h, Functor.assoc] @[simp] theorem up_comp_down {C : Type u₁} [Category.{v₁, u₁} C] : diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean index 0e00c2f0..18c2b15f 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean @@ -2,6 +2,7 @@ import HoTTLean.ForMathlib import Mathlib.CategoryTheory.Widesubcategory import HoTTLean.ForMathlib.CategoryTheory.Functor.Iso import HoTTLean.ForMathlib.CategoryTheory.FreeGroupoid +import Mathlib.Tactic.DepRewrite universe v u v₁ u₁ v₂ u₂ v₃ u₃ @@ -578,8 +579,8 @@ def lift : C ⥤ Algeria := def universal : (lift : C ⥤ Algeria) ×' lift ⋙ no = Cn ∧ lift ⋙ west = Cw ∧ ∀ {l0 l1 : C ⥤ Algeria}, l0 ⋙ no = l1 ⋙ no → l0 ⋙ west = l1 ⋙ west → l0 = l1 := - ⟨ lift esah_pb.comm_sq outer_pb Cn Cw hC, - by constructor + ⟨ lift esah_pb.comm_sq outer_pb Cn Cw hC, by + constructor . apply esah_pb.hom_ext . exact outer_pb.fac_left _ _ _ . rw [Functor.assoc, wsah, ← Functor.assoc, hC] diff --git a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean index 88cf0f60..d0c823da 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean @@ -3,6 +3,7 @@ import Mathlib.CategoryTheory.MorphismProperty.LiftingProperty import Mathlib.CategoryTheory.CodiscreteCategory import Mathlib.CategoryTheory.Monad.Limits import Mathlib.CategoryTheory.Category.Cat.Limit +import HoTTLean.ForMathlib.CategoryTheory.Functor.Iso universe w v u v₁ u₁ v₂ u₂ v₃ u₃ diff --git a/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean b/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean index 91b709b5..9b76e08f 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/NatTrans.lean @@ -149,4 +149,11 @@ theorem hComp {w : TwoSquare T L R B} {w' : TwoSquare T' R R' B'} (isCartesian_of_isIso _) end IsCartesian + +lemma hext {A : Type u} [Category.{v} A] {B: Type u₁} [Groupoid.{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 + aesop_cat + end NatTrans diff --git a/HoTTLean/ForMathlib/CategoryTheory/Whiskering.lean b/HoTTLean/ForMathlib/CategoryTheory/Whiskering.lean index 93015ce3..9c32f252 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Whiskering.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Whiskering.lean @@ -68,4 +68,13 @@ def whiskeringLeftObjWhiskeringRightObj : (A ⥤ B) ⥤ (C ⥤ D) := end +lemma comp_whiskerRight {A B C D : Type*} [Category A] [Category B] [Category C] [Category D] + {H0 H1 : D ⥤ A} (α : H0 ⟶ H1) (F : A ⥤ B) + (G : B ⥤ C) : whiskerRight α (F ⋙ G) = whiskerRight (whiskerRight α F) G := + rfl + +lemma id_whiskerRight {A B : Type*} [Category A] [Category B] + {H0 H1 : B ⥤ A} (α : H0 ⟶ H1) : whiskerRight α (𝟭 A) = α := + rfl + end CategoryTheory.Functor diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index bd49e93c..d568505b 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -1,5 +1,6 @@ import HoTTLean.ForMathlib import HoTTLean.ForMathlib.CategoryTheory.Grpd +import HoTTLean.ForMathlib.CategoryTheory.Bicategory.Grothendieck /-! ## Main definitions @@ -405,6 +406,9 @@ on `F` supplied as the first argument to `Groupoidal.functorFrom`. -/ def ιCompFunctorFrom (c : C) : ι F c ⋙ (functorFrom fib hom hom_id hom_comp) ≅ fib c := Grothendieck.ιCompFunctorFrom _ _ _ _ _ +def ι_comp_functorFrom (c : C) : ι F c ⋙ (functorFrom fib hom hom_id hom_comp) = fib c := + Grothendieck.ι_comp_functorFrom _ _ _ _ _ + section variable {D : Type*} [Category D] @@ -417,117 +421,100 @@ def hom' {c c' : C} (f : c ⟶ c') : fib' fib c ⟶ (F ⋙ Grpd.forgetToCat).map variable (G : E ⥤ D) -def functorFrom_comp_fib' (c : C) : (F ⋙ Grpd.forgetToCat).obj c ⥤ D := - Grothendieck.functorFrom_comp_fib (fib' fib) G c +def functorFromCompFib' (c : C) : (F ⋙ Grpd.forgetToCat).obj c ⥤ D := + Grothendieck.functorFromCompFib (fib' fib) G c -def functorFrom_comp_fib (c : C) : F.obj c ⥤ D := - functorFrom_comp_fib' fib G c +def functorFromCompFib (c : C) : F.obj c ⥤ D := + functorFromCompFib' fib G c -def functorFrom_comp_hom' {c c' : C} (f : c ⟶ c') : - functorFrom_comp_fib' fib G c ⟶ (F ⋙ Grpd.forgetToCat).map f ⋙ functorFrom_comp_fib' fib G c' := - Grothendieck.functorFrom_comp_hom (fib' fib) (hom' hom) _ _ +def functorFromCompHom' {c c' : C} (f : c ⟶ c') : + functorFromCompFib' fib G c ⟶ (F ⋙ Grpd.forgetToCat).map f ⋙ functorFromCompFib' fib G c' := + Grothendieck.functorFromCompHom (fib' fib) (hom' hom) _ _ -def functorFrom_comp_hom {c c' : C} (f : c ⟶ c') : - functorFrom_comp_fib' fib G c ⟶ F.map f ⋙ functorFrom_comp_fib' fib G c' := - functorFrom_comp_hom' fib hom G f +def functorFromCompHom {c c' : C} (f : c ⟶ c') : + functorFromCompFib' fib G c ⟶ F.map f ⋙ functorFromCompFib' fib G c' := + functorFromCompHom' fib hom G f include hom_id in -lemma functorFrom_comp_hom_id (c : C) : functorFrom_comp_hom fib hom G (𝟙 c) +lemma functorFromCompHom_id (c : C) : functorFromCompHom fib hom G (𝟙 c) = eqToHom (by simp) := - Grothendieck.functorFrom_comp_hom_id _ _ hom_id _ c + Grothendieck.functorFromCompHom_id _ _ hom_id _ c include hom_comp in -lemma functorFrom_comp_hom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃): - functorFrom_comp_hom fib (fun {c c'} ↦ hom) G (f ≫ g) - = functorFrom_comp_hom fib (fun {c c'} ↦ hom) G f ≫ - Functor.whiskerLeft (F.map f) (functorFrom_comp_hom fib hom G g) ≫ +lemma functorFromCompHom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃): + functorFromCompHom fib (fun {c c'} ↦ hom) G (f ≫ g) + = functorFromCompHom fib (fun {c c'} ↦ hom) G f ≫ + Functor.whiskerLeft (F.map f) (functorFromCompHom fib hom G g) ≫ eqToHom (by simp) := - Grothendieck.functorFrom_comp_hom_comp _ _ hom_comp _ _ _ _ _ _ + Grothendieck.functorFromCompHom_comp _ _ hom_comp _ _ _ _ _ _ -lemma functorFrom_comp_hom_eq {c c' : C} (f : c ⟶ c') : - functorFrom_comp_hom fib hom G f = whiskerRight (hom f) G := +lemma functorFromCompHom_eq {c c' : C} (f : c ⟶ c') : + functorFromCompHom fib hom G f = whiskerRight (hom f) G := rfl theorem functorFrom_comp' : functorFrom (fib' fib) (hom' hom) hom_id hom_comp ⋙ G = - functorFrom (functorFrom_comp_fib' fib G) (functorFrom_comp_hom' fib hom G) - (functorFrom_comp_hom_id _ _ hom_id _) (functorFrom_comp_hom_comp _ _ hom_comp _) := + functorFrom (functorFromCompFib' fib G) (functorFromCompHom' fib hom G) + (functorFromCompHom_id _ _ hom_id _) (functorFromCompHom_comp _ _ hom_comp _) := Grothendieck.functorFrom_comp (fib' fib) (hom' hom) hom_id hom_comp G theorem functorFrom_comp : functorFrom fib hom hom_id hom_comp ⋙ G = - functorFrom (functorFrom_comp_fib fib G) (functorFrom_comp_hom fib hom G) - (Grothendieck.functorFrom_comp_hom_id _ _ hom_id _) - (Grothendieck.functorFrom_comp_hom_comp _ _ hom_comp _) := + functorFrom (functorFromCompFib fib G) (functorFromCompHom fib hom G) + (Grothendieck.functorFromCompHom_id _ _ hom_id _) + (Grothendieck.functorFromCompHom_comp _ _ hom_comp _) := functorFrom_comp' fib hom hom_id hom_comp G variable (K : ∫(F) ⥤ E) -def asFunctorFrom_fib (c : C) : F.obj c ⥤ E := - Grothendieck.asFunctorFrom_fib K c - -lemma asFunctorFrom_fib' (c : C) : asFunctorFrom_fib K c = ι F c ⋙ K := - rfl - -def asFunctorFrom_hom {c c' : C} (f: c ⟶ c') : - asFunctorFrom_fib K c ⟶ F.map f ⋙ asFunctorFrom_fib K c' := - Grothendieck.asFunctorFrom_hom K f +abbrev asFunctorFromFib (c : C) : F.obj c ⥤ E := ι F c ⋙ K -section - -variable {E : Type*} [Category E] -variable (fib : ∀ c, F.obj c ⥤ E) (hom : ∀ {c c' : C} (f : c ⟶ c'), fib c ⟶ F.map f ⋙ fib c') -variable (hom_id : ∀ c, hom (𝟙 c) = eqToHom (by simp only [Functor.map_id]; rfl)) -variable (hom_comp : ∀ c₁ c₂ c₃ (f : c₁ ⟶ c₂) (g : c₂ ⟶ c₃), hom (f ≫ g) = - hom f ≫ (F.map f).whiskerLeft (hom g) ≫ eqToHom (by simp only [Functor.map_comp]; rfl)) +abbrev asFunctorFromHom {c c' : C} (f: c ⟶ c') : + asFunctorFromFib K c ⟶ F.map f ⋙ asFunctorFromFib K c' := + Functor.whiskerRight (ιNatTrans f) K -lemma asFunctorFrom_fib_functorFrom : - asFunctorFrom_fib (functorFrom fib hom hom_id hom_comp) = fib := by - unfold asFunctorFrom_fib functorFrom - simp - sorry - --- lemma asFunctorFrom_hom_functorFrom {K} {c c' : C} (f : c ⟶ c') : - -- asFunctorFrom_hom (functorFrom fib hom hom_id hom_comp) K f ≫ eqToHom sorry = - -- eqToHom sorry ≫ hom K f := by - -- unfold asFunctorFrom_fib functorFrom - -- simp - -- sorry -end +-- TODO: remove? +lemma asFunctorFromFib_functorFrom : + asFunctorFromFib (functorFrom fib hom hom_id hom_comp) = fib := by + unfold asFunctorFromFib + ext + rw [ι_comp_functorFrom] -lemma asFunctorFrom_hom' {c c' : C} (f: c ⟶ c') : - asFunctorFrom_hom K f = whiskerRight (ιNatTrans f) K := rfl +lemma asFunctorFromHom' {c c' : C} (f: c ⟶ c') : + asFunctorFromHom K f = whiskerRight (ιNatTrans f) K := rfl -lemma asFunctorFrom_hom_app {c c' : C} (f: c ⟶ c') (p : F.obj c) : - (asFunctorFrom_hom K f).app p = K.map ((ιNatTrans f).app p) := +lemma asFunctorFromHom_app {c c' : C} (f: c ⟶ c') (p : F.obj c) : + (asFunctorFromHom K f).app p = K.map ((ιNatTrans f).app p) := rfl -lemma asFunctorFrom_hom_id (c : C) : asFunctorFrom_hom K (𝟙 c) = +lemma asFunctorFromHom_id (c : C) : asFunctorFromHom K (𝟙 c) = eqToHom (by simp) := - Grothendieck.asFunctorFrom_hom_id _ _ + Grothendieck.asFunctorFromHom_id _ _ -lemma asFunctorFrom_hom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g: c₂ ⟶ c₃) : - asFunctorFrom_hom K (f ≫ g) = - asFunctorFrom_hom K f ≫ Functor.whiskerLeft (F.map f) (asFunctorFrom_hom K g) ≫ eqToHom +lemma asFunctorFromHom_comp (c₁ c₂ c₃ : C) (f : c₁ ⟶ c₂) (g: c₂ ⟶ c₃) : + asFunctorFromHom K (f ≫ g) = + asFunctorFromHom K f ≫ Functor.whiskerLeft (F.map f) (asFunctorFromHom K g) ≫ eqToHom (by simp) := - Grothendieck.asFunctorFrom_hom_comp _ _ _ _ _ _ + Grothendieck.asFunctorFromHom_comp _ _ _ _ _ _ /-- Groupoidal version of `Grothendieck.asFunctorFrom` -/ -theorem asFunctorFrom : functorFrom (asFunctorFrom_fib K) (asFunctorFrom_hom K) - (asFunctorFrom_hom_id K) (asFunctorFrom_hom_comp K) = K := +theorem asFunctorFrom : functorFrom (asFunctorFromFib K) (asFunctorFromHom K) + (asFunctorFromHom_id K) (asFunctorFromHom_comp K) = K := Grothendieck.asFunctorFrom K theorem functorFrom_ext {K K' : ∫(F) ⥤ E} - (hfib : asFunctorFrom_fib K = asFunctorFrom_fib K') - (hhom : ∀ {c c' : C} (f : c ⟶ c'), asFunctorFrom_hom K f ≫ eqToHom (by rw [hfib]) - = eqToHom (by rw[hfib]) ≫ asFunctorFrom_hom K' f) + (hfib : ∀ c, ι F c ⋙ K = ι F c ⋙ K') + (hhom : ∀ {c c' : C} (f : c ⟶ c'), Functor.whiskerRight (ιNatTrans f) K ≫ + eqToHom (by simp [Functor.assoc, hfib]) + = eqToHom (by rw[hfib]) ≫ Functor.whiskerRight (ιNatTrans f) K') : K = K' := Grothendieck.functorFrom_ext hfib hhom theorem functorFrom_hext {K K' : ∫(F) ⥤ E} - (hfib : asFunctorFrom_fib K = asFunctorFrom_fib K') - (hhom : ∀ {c c' : C} (f : c ⟶ c'), asFunctorFrom_hom K f ≍ asFunctorFrom_hom K' f) + (hfib : ∀ c, ι F c ⋙ K = ι F c ⋙ K') + (hhom : ∀ {c c' : C} (f : c ⟶ c'), Functor.whiskerRight (ιNatTrans f) K ≍ + Functor.whiskerRight (ιNatTrans f) K') : K = K' := Grothendieck.functorFrom_hext hfib hhom @@ -573,6 +560,14 @@ variable {X} {Y : ∫(F)} (f : X ⟶ Y) eqToHom (Functor.congr_obj (α.naturality f.base).symm X.fiber) ≫ (α.app Y.base).map f.fiber := Grothendieck.map_map_fiber _ _ +/-- The fiber inclusion `ι F c` composed with `map α` is isomorphic to `α.app c ⋙ ι F' c`. -/ +@[simps!] +def ιCompMap {F' : C ⥤ Grpd} (α : F ⟶ F') (c : C) : ι F c ⋙ map α ≅ α.app c ⋙ ι F' c := + Grothendieck.ιCompMap .. + +lemma ι_comp_map {F' : C ⥤ Grpd} (α : F ⟶ F') (c : C) : ι F c ⋙ map α = α.app c ⋙ ι F' c := + Grothendieck.ι_comp_map .. + end section diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index 7f16c9b0..fb019f8d 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -549,8 +549,8 @@ theorem ι_sigma_comp_map_fstAux (x) : ι (sigma A B) x ⋙ map (fstAux B) · rfl · simp -theorem functorFrom_comp_fib_assocFib_forget : - functorFrom_comp_fib (assocFib B) forget = asFunctorFrom_fib (map (fstAux B)) := by +theorem functorFromCompFib_assocFib_forget : + functorFromCompFib (assocFib B) forget = asFunctorFromFib (map (fstAux B)) := by ext x exact (ι_sigma_comp_map_fstAux B x).symm @@ -565,7 +565,7 @@ theorem assoc_forget : assoc B ⋙ forget = fstAux' B := by simp only [assoc, fstAux', functorFrom_comp] rw [← asFunctorFrom (map (fstAux B))] fapply Functor.Grothendieck.functorFrom_eq_of -- FIXME: bleeding Grothendieck - · exact functorFrom_comp_fib_assocFib_forget B + · exact functorFromCompFib_assocFib_forget B · intro c₁ c₂ f rw [comp_eqToHom_iff] ext x From d0a7c973fc11fdf3afd938cd2b63f5771f36c12d Mon Sep 17 00:00:00 2001 From: jlh18 Date: Fri, 10 Oct 2025 01:44:59 -0400 Subject: [PATCH 41/59] prove grothendeickClassifierIso --- .../Bicategory/Grothendieck.lean | 31 +- .../CategoryTheory/SplitIsofibration.lean | 354 +++++++++++------- HoTTLean/Grothendieck/Groupoidal/Basic.lean | 129 ++++--- 3 files changed, 308 insertions(+), 206 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index 4b253597..6322c67a 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean @@ -1261,18 +1261,19 @@ variable (A : E ⥤ C) (fibObj : (x : E) → (A ⋙ F).obj x) @[simps!] def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget F) - (fibObj_fib_obj : ∀ {c} x, fibObj ((fib c).obj x) ≍ x) - (fibMap_fib_map : ∀ {c} {x y} (f : x ⟶ y), fibMap ((fib c).map f) ≍ f) - (fib_obj_fibObj : ∀ x, (fib (A.obj x)).obj (fibObj x) = x) - (hom_map_app_fibObj : ∀ {x y} (f : x ⟶ y), (hom (A.map f)).app (fibObj x) ≫ - (fib (A.obj y)).map (fibMap f) ≍ f) - (whiskerRight_functorTo : ∀ {x y} (f : x ⟶ y), whiskerRight (hom f) - (functorTo A fibObj fibMap map_id map_comp) ≍ ιNatTrans (F := F) f) - : ∫ F ≅≅ E where + (fibObj_fib_obj : ∀ c x, fibObj ((fib c).obj x) ≍ x) + (fibMap_fib_map : ∀ c {x y} (f : x ⟶ y), fibMap ((fib c).map f) ≍ f) + (fib_obj_fibObj : ∀ x, (fib (A.obj x)).obj (fibObj x) = x) + (hom_map_app_fibObj : ∀ {x y} (f : x ⟶ y), (hom (A.map f)).app (fibObj x) ≫ + (fib (A.obj y)).map (fibMap f) ≍ f) + (obj_fib_obj : ∀ c x, A.obj ((fib c).obj x) = c) + (map_hom_app : ∀ {c c'} (f : c ⟶ c') x, A.map ((hom f).app x) ≍ f) + (fibMap_hom_app : ∀ {c c'} (f : c ⟶ c') x, fibMap ((hom f).app x) ≍ 𝟙 ((F.map f).obj x)) : + ∫ F ≅≅ E where hom := functorFrom fib hom hom_id hom_comp inv := functorTo A fibObj fibMap map_id map_comp hom_inv_id := by - fapply functorFrom_hext + fapply functorFrom_ext · intro c rw [← Functor.assoc, ι_comp_functorFrom] apply FunctorTo.hext @@ -1284,9 +1285,15 @@ def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget F) rw! [eqToHom_comp_heq, heq_cast_iff_heq] apply fibMap_fib_map · intro c c' f - simp only [comp_whiskerRight, whiskerRight_ιNatTrans_functorFrom, whiskerRight_comp, - eqToHom_whiskerRight, id_whiskerRight, eqToHom_comp_heq_iff, comp_eqToHom_heq_iff] - apply whiskerRight_functorTo + apply NatTrans.ext + ext x + simp only [comp_obj, functorFrom_obj, ι_obj_base, ι_obj_fiber, id_obj, comp_whiskerRight, + whiskerRight_ιNatTrans_functorFrom, whiskerRight_comp, eqToHom_whiskerRight, Category.assoc, + eqToHom_trans, NatTrans.comp_app, eqToHom_app, eqToHom_refl, whiskerRight_app, + Category.id_comp, id_whiskerRight, ← heq_eq_eq, heq_eqToHom_comp_iff, comp_eqToHom_heq_iff] + apply Grothendieck.Hom.hext' rfl + any_goals apply Grothendieck.hext' rfl + all_goals simp [obj_fib_obj, fibObj_fib_obj, fibMap_hom_app, map_hom_app] inv_hom_id := by fapply Functor.ext · intro x diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 4f9b2b8d..4823b9da 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -9,9 +9,39 @@ 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 + 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 ⥤ Γ} @@ -47,6 +77,7 @@ variable {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' +@[simp] lemma ClovenIsofibration.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') @@ -68,6 +99,13 @@ lemma ClovenIsofibration.liftObj_comp_aux {X Y : D} (f : X ⟶ Y) [IsIso f] {X' subst hY' apply ClovenIsofibration.obj_liftObj I f +lemma ClovenIsofibration.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 + end structure SplitClovenIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] @@ -93,6 +131,20 @@ namespace SplitClovenIsofibration open ClovenIsofibration +@[simp] +lemma liftObj_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] + (F : C ⥤ D) (I : SplitClovenIsofibration F) {X Y : D} (h : X = Y) {X' : C} + (hX' : F.obj X' = X) : I.liftObj (eqToHom h) hX' = X' := by + subst h + simp [liftObj_id] + +@[simp] +lemma liftIso_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] (F : C ⥤ D) + (I : SplitClovenIsofibration F) {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 [liftIso_id] + variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} (I : SplitClovenIsofibration F) @@ -102,17 +154,7 @@ variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E /-- Any isofibration `F : E ⥤ Γ` of groupoids is classified by a functor `classifier : Γ ⥤ Grpd`. -/ def classifier.map.obj {X Y : Γ} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := - ⟨I.liftObj f a.2, by - have p : F.IsHomLift f (I.liftIso f _) := I.isHomLift f (X' := a.1) a.2 - apply @IsHomLift.codomain_eq (f := f) (φ := I.liftIso (X' := a.1) f a.2) ⟩ - -lemma classifier.fac' {X} {a b : F.Fiber X} (m : a ⟶ b) : - F.map (Fiber.fiberInclusion.map m) = - eqToHom (by simp [Fiber.fiberInclusion, a.2, b.2]) := by - erw [@IsHomLift.fac' _ _ _ _ F _ _ _ _ (𝟙 X) _ m.2] - simp - - + ⟨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 := @@ -121,8 +163,7 @@ def classifier.map.map {X Y} (f: X ⟶ Y) {a b : F.Fiber X} (m : a ⟶ b) : 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, classifier.fac', Functor.map_inv,map_liftIso'] + := 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 ..) @@ -200,8 +241,12 @@ 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 := by - apply classifier.map_comp + 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 @@ -300,24 +345,25 @@ hom.map' I (f ≫ g) = hom.map' I f ≫ hom.map' I g := by -- sorry --convert_to _ ≫ eqToHom _ ≫ Fiber.fiberInclusion.map _ ≫ _ = _ -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] +@[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 := +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]) + (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]) -lemma grothendieckClassifierIso.hom_comp_self : hom I ⋙ F = Groupoidal.forget := by +-- lemma grothendieckClassifierIso.hom_comp_self : hom I ⋙ F = Groupoidal.forget := by - #check functorFrom_ext - sorry +-- #check functorFrom_ext +-- sorry -- def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E where -- obj p := p.fiber.1 @@ -330,7 +376,7 @@ def grothendieckClassifierIso.inv.fibMap {X Y}(f : X ⟶ Y) : -- simp[classifier,classifier.map.obj] refine @Fiber.homMk _ _ _ _ F (F.obj Y) _ _ ?_ ?_ · exact CategoryTheory.inv (I.liftIso (F.map f) rfl) ≫ f - · simp[] + · simp fapply IsHomLift.of_fac · simp[ClovenIsofibration.obj_liftObj] · rfl @@ -353,104 +399,122 @@ lemma grothendieckClassifierIso.inv.fibMap_comp {x y z : E} (f : x ⟶ y) (g : y simp[liftIso_comp] simp[eqToHom_map,classifier,classifier.map.map] -def grothendieckClassifierIso.inv : E ⥤ ∫ I.classifier := - Groupoidal.functorTo F (fun x => ⟨x, rfl⟩) - (fun f => inv.fibMap I f) - (fun x => inv.fibMap_id I x) - (fun f g => inv.fibMap_comp I f g) - -lemma grothendieckClassifierIso.inv_comp_forget : grothendieckClassifierIso.inv I ⋙ - Groupoidal.forget = F := - Groupoidal.functorTo_forget - - -lemma Fiber.fiberInclusion.obj.fiber (p : ∫ I.classifier): - F.obj (Fiber.fiberInclusion.obj p.fiber) = p.base := by - apply grothendieckClassifierIso.hom.map_aux2 - --- lemma Fiber.hext {x y} {a: F.Fiber x} {b: F.Fiber y} --- (hbase: x = y) --- (hfib : --- Fiber.fiberInclusion.obj b = - --- (F.map (eqToHom hbase)).obj sorry ) : a ≍ b := sorry - -#check Fiber.hom_ext - - -lemma hom_hext {x : Γ } {a b : Fiber F x} (φ ψ : a ⟶ b) - (h : Fiber.fiberInclusion.map φ = Fiber.fiberInclusion.map ψ) : φ ≍ ψ := sorry - --Subtype.ext h - -def grothendieckClassifierIso : ∫ I.classifier ≅≅ E where - hom := grothendieckClassifierIso.hom .. - inv := grothendieckClassifierIso.inv .. - hom_inv_id := by - fapply Functor.Groupoidal.FunctorTo.hext - · simp [Functor.assoc, grothendieckClassifierIso.inv_comp_forget,grothendieckClassifierIso.hom_comp_self] - · intro p - simp[grothendieckClassifierIso.inv] - simp[grothendieckClassifierIso.hom] - rw[Subtype.heq_iff_coe_eq] - · simp;rfl - · intro - simp - rw[Fiber.fiberInclusion.obj.fiber] - · intro x y f - simp - /- (I.classifier.map (Hom.base f)).obj x.fiber ⟶ y.fiber : ↑(I.classifier.obj y.base) - in E - f : x ⟶ y - - - -/ - congr - · simp[grothendieckClassifierIso.inv,grothendieckClassifierIso.hom ] - apply Functor.Groupoidal.ext - · simp[classifier,classifier.map.obj] - - sorry - sorry - · sorry - · apply Functor.Groupoidal.Hom.hext' sorry sorry sorry - · simp[grothendieckClassifierIso.inv,grothendieckClassifierIso.hom] - simp[grothendieckClassifierIso.hom'.hom,← Functor.map_comp] - sorry - · sorry - -- apply hom_hext - -- simp[grothendieckClassifierIso.inv,grothendieckClassifierIso.hom] - -- simp[grothendieckClassifierIso.inv.fibMap] - -- apply Groupoidal.Hom.hext' - -- simp[functorFrom_map] - -- sorry --- fapply ext - -- · intro p - -- simp[grothendieckClassifierIso.hom,grothendieckClassifierIso.inv] --- fapply CategoryTheory.Functor.Groupoidal.ext --- · rw[functorTo_obj_base] --- · apply grothendieckClassifierIso.hom.map_aux2 --- · intro x y z f g --- simp[grothendieckClassifierIso.inv.fibMap,classifier,classifier.map.map] --- rw![Functor.map_comp] --- simp[Fiber.homMk,liftIso_comp] --- ext --- simp[eqToHom_map] --- congr --- · rw![functorTo_obj_fiber] --- · simp --- simp[grothendieckClassifierIso.inv.fibMap,classifier, classifier.map.obj] --- rw![grothendieckClassifierIso.hom.map_aux2] --- rw! (castMode := .all) [functorTo_obj_base] --- --F.obj (I.liftObj (eqToHom ⋯) ⋯) = p.base --- --apply Fiber.hom_ext --- --fapply CategoryTheory.Functor.Groupoidal.hext --- --simp[eqToHom_map] --- sorry - --- · sorry - - - inv_hom_id := sorry +-- def grothendieckClassifierIso.inv : E ⥤ ∫ I.classifier := +-- Groupoidal.functorTo F (fun x => ⟨x, rfl⟩) +-- (fun f => inv.fibMap I f) +-- (fun x => inv.fibMap_id I x) +-- (fun f g => inv.fibMap_comp I f g) + +-- lemma grothendieckClassifierIso.inv_comp_forget : grothendieckClassifierIso.inv I ⋙ + -- Groupoidal.forget = F := + -- Groupoidal.functorTo_forget + +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 .. + +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] + +@[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 +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', I.liftObj_comp _ _ _ _ rfl, I.liftObj_comp _ _ _ _ rfl] + simp [liftObj_eqToHom] + · rw! [map_liftIso', I.liftIso_comp _ _ _ _ rfl, I.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 [I.liftObj_comp _ _ _ _ rfl, I.liftObj_comp _ _ _ _ rfl] + simp) + +-- def grothendieckClassifierIso' : ∫ I.classifier ≅≅ E where +-- hom := grothendieckClassifierIso.hom .. +-- inv := grothendieckClassifierIso.inv .. +-- hom_inv_id := by +-- fapply Functor.Groupoidal.FunctorTo.hext +-- · simp [Functor.assoc, grothendieckClassifierIso.inv_comp_forget,grothendieckClassifierIso.hom_comp_self] +-- · sorry +-- · sorry +-- -- fapply ext +-- -- · intro p +-- -- simp[grothendieckClassifierIso.hom,grothendieckClassifierIso.inv] +-- -- fapply CategoryTheory.Functor.Groupoidal.ext +-- -- · rw[functorTo_obj_base] +-- -- · apply grothendieckClassifierIso.hom.map_aux2 +-- -- · intro x y z f g +-- -- simp[grothendieckClassifierIso.inv.fibMap,classifier,classifier.map.map] +-- -- rw![Functor.map_comp] +-- -- simp[Fiber.homMk,liftIso_comp] +-- -- ext +-- -- simp[eqToHom_map] +-- -- congr +-- -- · rw![functorTo_obj_fiber] +-- -- · simp +-- -- simp[grothendieckClassifierIso.inv.fibMap,classifier, classifier.map.obj] +-- -- rw![grothendieckClassifierIso.hom.map_aux2] +-- -- rw! (castMode := .all) [functorTo_obj_base] +-- -- --F.obj (I.liftObj (eqToHom ⋯) ⋯) = p.base +-- -- --apply Fiber.hom_ext +-- -- --fapply CategoryTheory.Functor.Groupoidal.hext +-- -- --simp[eqToHom_map] +-- -- sorry + +-- -- · sorry + + +-- inv_hom_id := sorry def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : SplitClovenIsofibration F.hom where @@ -506,24 +570,24 @@ def comp.isHomLift {X Y: C} (f: X ⟶ Y) [i:IsIso f] {X': A} (hX': (F ⋙ G).obj 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] - rw![liftIso_id] - --have i: IsIso (eqToHom sorry ≫ 𝟙 _) := sorry - have h1 : eqToHom (Eq.symm (IG.liftObj_id hX')) = eqToHom (Eq.symm (IG.liftObj_id hX')) ≫ 𝟙 _ := sorry - rw![h1] - rw [liftObj_comp] - have e0 : IG.liftObj (𝟙 X) hX' = F.obj X' := sorry - rw![e0] - · - sorry - · sorry - --convert_to @liftObj _ _ _ _ _ _ _ IF _ _ (𝟙 (F.obj X')) _ = _ - · sorry - --apply liftObj_id - --- have h : IF.liftObj (eqToHom (Eq.symm (IG.liftObj_id hX'))) rfl = X':= sorry --- have h: IF.liftObj (eqToHom (Eq.symm (IG.liftObj_id hX')) ≫ 𝟙 (F.obj X')) (by sorry) = X' := sorry --- simp[eqToHom] --- sorry +-- rw![liftIso_id] +-- --have i: IsIso (eqToHom sorry ≫ 𝟙 _) := sorry +-- have h1 : eqToHom (Eq.symm (IG.liftObj_id hX')) = eqToHom (Eq.symm (IG.liftObj_id hX')) ≫ 𝟙 _ := sorry +-- rw![h1] +-- rw [liftObj_comp] +-- have e0 : IG.liftObj (𝟙 X) hX' = F.obj X' := sorry +-- rw![e0] +-- · +-- sorry +-- · sorry +-- --convert_to @liftObj _ _ _ _ _ _ _ IF _ _ (𝟙 (F.obj X')) _ = _ +-- · sorry +-- --apply liftObj_id + +-- -- have h : IF.liftObj (eqToHom (Eq.symm (IG.liftObj_id hX'))) rfl = X':= sorry +-- -- have h: IF.liftObj (eqToHom (Eq.symm (IG.liftObj_id hX')) ≫ 𝟙 (F.obj X')) (by sorry) = X' := sorry +-- -- simp[eqToHom] +-- -- sorry diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index d568505b..f111b388 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -282,7 +282,7 @@ theorem ι_map (c : C) {X Y : F.obj c} (f : X ⟶ Y) : ((ι F c).map f).fiber = eqToHom (by simp) ≫ f := rfl -@[simp] theorem ι_comp_forget (c : C) : ι F c ⋙ forget = (const (F.obj c)).obj c := +theorem ι_comp_forget (c : C) : ι F c ⋙ forget = (const (F.obj c)).obj c := rfl variable {F} @@ -356,6 +356,54 @@ theorem FunctorTo.hext (G H : D ⥤ ∫ F) end ext +section +variable {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] +variable {F : C ⥤ Grpd.{v₂, u₂}} (A : D ⥤ C) (fibObj : Π (x : D), (A ⋙ F).obj x) + (fibMap : Π {x y : D} (f : x ⟶ y), + ((A ⋙ F).map f).obj (fibObj x) ⟶ fibObj y) + +theorem functorTo_map_id_aux (x : D) : ((A ⋙ F).map (𝟙 x)).obj (fibObj x) = fibObj x := by + simp + +theorem functorTo_map_comp_aux {x y z : D} (f : x ⟶ y) (g : y ⟶ z) : + ((A ⋙ F).map (f ≫ g)).obj (fibObj x) + = (F.map (A.map g)).obj (((A ⋙ F).map f).obj (fibObj x)) := by + simp + +variable + (map_id : Π (x : D), fibMap (CategoryStruct.id x) + = eqToHom (functorTo_map_id_aux A fibObj x)) + (map_comp : Π {x y z : D} (f : x ⟶ y) (g : y ⟶ z), fibMap (f ≫ g) + = eqToHom (functorTo_map_comp_aux A fibObj f g) + ≫ (F.map (A.map g)).map (fibMap f) ≫ fibMap g) + +/-- To define a functor into `Grothendieck F` we can make use of an existing + functor into the base. -/ +def functorTo : D ⥤ ∫(F) := Grothendieck.functorTo A fibObj fibMap map_id map_comp + +@[simp] theorem functorTo_obj_base (x) : + ((functorTo A fibObj fibMap map_id map_comp).obj x).base = A.obj x := + rfl + +@[simp] theorem functorTo_obj_fiber (x) : + ((functorTo A fibObj fibMap map_id map_comp).obj x).fiber = fibObj x := + rfl + +@[simp] theorem functorTo_map_base {x y} (f : x ⟶ y) : + ((functorTo A fibObj fibMap map_id map_comp).map f).base = A.map f := + rfl + +@[simp] theorem functorTo_map_fiber {x y} (f : x ⟶ y) : + ((functorTo A fibObj fibMap map_id map_comp).map f).fiber = fibMap f := + rfl + +variable {A} {fibObj} {fibMap} {map_id} {map_comp} +@[simp] theorem functorTo_forget : + functorTo _ _ _ map_id map_comp ⋙ Grothendieck.forget _ = A := + rfl + +end + /-- Every morphism `f : X ⟶ Y` in the base category induces a natural transformation from the fiber inclusion `ι F X` to the composition `F.map f ⋙ ι F Y`. -/ def ιNatTrans {X Y : C} (f : X ⟶ Y) : ι F X ⟶ F.map f ⋙ ι F Y := @@ -409,6 +457,12 @@ def ιCompFunctorFrom (c : C) : ι F c ⋙ (functorFrom fib hom hom_id hom_comp) def ι_comp_functorFrom (c : C) : ι F c ⋙ (functorFrom fib hom hom_id hom_comp) = fib c := Grothendieck.ι_comp_functorFrom _ _ _ _ _ +lemma whiskerRight_ιNatTrans_functorFrom {x y} (f : x ⟶ y) : + Functor.whiskerRight (ιNatTrans f) (functorFrom fib hom hom_id hom_comp) = + eqToHom (ι_comp_functorFrom ..) ≫ hom f ≫ + eqToHom (by rw [Functor.assoc, ι_comp_functorFrom]) := + Grothendieck.whiskerRight_ιNatTrans_functorFrom .. + section variable {D : Type*} [Category D] @@ -518,6 +572,31 @@ theorem functorFrom_hext {K K' : ∫(F) ⥤ E} : K = K' := Grothendieck.functorFrom_hext hfib hhom +section +variable (A : E ⥤ C) (fibObj : (x : E) → (A ⋙ F).obj x) + (fibMap : {x y : E} → (f : x ⟶ y) → ((A ⋙ F).map f).obj (fibObj x) ⟶ fibObj y) + (map_id : (x : E) → fibMap (CategoryStruct.id x) + = eqToHom (functorTo_map_id_aux A fibObj x)) + (map_comp : {x y z : E} → (f : x ⟶ y) → (g : y ⟶ z) → fibMap (f ≫ g) + = eqToHom (functorTo_map_comp_aux A fibObj f g) + ≫ (F.map (A.map g)).map (fibMap f) ≫ fibMap g) + +@[simps!] +def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget) + (fibObj_fib_obj : ∀ c x, fibObj ((fib c).obj x) ≍ x) + (fibMap_fib_map : ∀ c {x y} (f : x ⟶ y), fibMap ((fib c).map f) ≍ f) + (fib_obj_fibObj : ∀ x, (fib (A.obj x)).obj (fibObj x) = x) + (hom_map_app_fibObj : ∀ {x y} (f : x ⟶ y), (hom (A.map f)).app (fibObj x) ≫ + (fib (A.obj y)).map (fibMap f) ≍ f) + (obj_fib_obj : ∀ c x, A.obj ((fib c).obj x) = c) + (map_hom_app : ∀ {c c'} (f : c ⟶ c') x, A.map ((hom f).app x) ≍ f) + (fibMap_hom_app : ∀ {c c'} (f : c ⟶ c') x, fibMap ((hom f).app x) ≍ 𝟙 ((F.map f).obj x)) : + ∫ F ≅≅ E := + Grothendieck.functorIsoFrom fib hom hom_id hom_comp A fibObj fibMap map_id map_comp + fib_comp fibObj_fib_obj fibMap_fib_map fib_obj_fibObj hom_map_app_fibObj + obj_fib_obj map_hom_app fibMap_hom_app + +end end end FunctorFrom @@ -771,54 +850,6 @@ theorem ιNatIso_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : end -section -variable {C : Type u} [Category.{v} C] {D : Type u₁} [Category.{v₁} D] -variable {F : C ⥤ Grpd.{v₂, u₂}} (A : D ⥤ C) (fibObj : Π (x : D), (A ⋙ F).obj x) - (fibMap : Π {x y : D} (f : x ⟶ y), - ((A ⋙ F).map f).obj (fibObj x) ⟶ fibObj y) - -theorem functorTo_map_id_aux (x : D) : ((A ⋙ F).map (𝟙 x)).obj (fibObj x) = fibObj x := by - simp - -theorem functorTo_map_comp_aux {x y z : D} (f : x ⟶ y) (g : y ⟶ z) : - ((A ⋙ F).map (f ≫ g)).obj (fibObj x) - = (F.map (A.map g)).obj (((A ⋙ F).map f).obj (fibObj x)) := by - simp - -variable - (map_id : Π (x : D), fibMap (CategoryStruct.id x) - = eqToHom (functorTo_map_id_aux A fibObj x)) - (map_comp : Π {x y z : D} (f : x ⟶ y) (g : y ⟶ z), fibMap (f ≫ g) - = eqToHom (functorTo_map_comp_aux A fibObj f g) - ≫ (F.map (A.map g)).map (fibMap f) ≫ fibMap g) - -/-- To define a functor into `Grothendieck F` we can make use of an existing - functor into the base. -/ -def functorTo : D ⥤ ∫(F) := Grothendieck.functorTo A fibObj fibMap map_id map_comp - -@[simp] theorem functorTo_obj_base (x) : - ((functorTo A fibObj fibMap map_id map_comp).obj x).base = A.obj x := - rfl - -@[simp] theorem functorTo_obj_fiber (x) : - ((functorTo A fibObj fibMap map_id map_comp).obj x).fiber = fibObj x := - rfl - -@[simp] theorem functorTo_map_base {x y} (f : x ⟶ y) : - ((functorTo A fibObj fibMap map_id map_comp).map f).base = A.map f := - rfl - -@[simp] theorem functorTo_map_fiber {x y} (f : x ⟶ y) : - ((functorTo A fibObj fibMap map_id map_comp).map f).fiber = fibMap f := - rfl - -variable {A} {fibObj} {fibMap} {map_id} {map_comp} -@[simp] theorem functorTo_forget : - functorTo _ _ _ map_id map_comp ⋙ Grothendieck.forget _ = A := - rfl - -end - section -- TODO factor through Grothendieck From 3d9a7ffbe884531d8b5f2a48ba2e3170038da3dc Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Mon, 13 Oct 2025 12:23:45 -0400 Subject: [PATCH 42/59] problem on line 603 --- .../CategoryTheory/SplitIsofibration.lean | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 4823b9da..249ebd58 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -590,6 +590,20 @@ lemma comp.liftObj_id {X: C} {X': A} (hX': (F ⋙ G).obj X' = X): -- -- sorry +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 + simp[comp.liftIso] + have e : (IG.liftIso (𝟙 X) hX') = eqToHom (by simp[SplitClovenIsofibration.liftObj_id]) := by + apply SplitClovenIsofibration.liftIso_id + + --let e:= SplitClovenIsofibration.liftIso_id (X' := F.obj X') + --rw! (castMode := .all)[liftIso_eqToHom] + rw! (castMode := .all)[e] + rw[liftIso_eqToHom] + rw!(castMode := .all)[liftObj_eqToHom] + + sorry + /-- `IsMultiplicative` 1/2 -/ def comp : @@ -600,7 +614,9 @@ def comp : liftObj_id := by intro X X' hX' apply comp.liftObj_id - liftIso_id := sorry + liftIso_id := by + intro X X' hX' + apply comp.liftIso_id liftObj_comp := by sorry liftIso_comp := sorry From 0cee5451305453f1b6d199eaafcfb73ecc5db1c2 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Mon, 13 Oct 2025 22:34:01 -0400 Subject: [PATCH 43/59] fix: comp.liftIso_id --- .../CategoryTheory/SplitIsofibration.lean | 30 +++++++++++-------- 1 file changed, 17 insertions(+), 13 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 249ebd58..351effde 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -590,19 +590,23 @@ lemma comp.liftObj_id {X: C} {X': A} (hX': (F ⋙ G).obj X' = X): -- -- sorry -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 - simp[comp.liftIso] - have e : (IG.liftIso (𝟙 X) hX') = eqToHom (by simp[SplitClovenIsofibration.liftObj_id]) := by - apply SplitClovenIsofibration.liftIso_id - - --let e:= SplitClovenIsofibration.liftIso_id (X' := F.obj X') - --rw! (castMode := .all)[liftIso_eqToHom] - rw! (castMode := .all)[e] - rw[liftIso_eqToHom] - rw!(castMode := .all)[liftObj_eqToHom] - - sorry +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 + simp [comp.liftIso] + rw! (castMode := .all) [IG.liftIso_id] + simp [← heq_eq_eq] + apply HEq.trans (eqToHom_heq_id_dom _ _ _) (eqToHom_heq_id_dom _ _ _).symm + + -- have e : (IG.liftIso (𝟙 X) hX') = eqToHom (by simp[SplitClovenIsofibration.liftObj_id]) := by + -- apply SplitClovenIsofibration.liftIso_id + + -- --let e:= SplitClovenIsofibration.liftIso_id (X' := F.obj X') + -- --rw! (castMode := .all)[liftIso_eqToHom] + -- rw! (castMode := .all)[e] + -- rw[liftIso_eqToHom] + -- rw!(castMode := .all)[liftObj_eqToHom] + + -- sorry /-- `IsMultiplicative` 1/2 -/ From 9b86ffcd0293169c124743dbd88b2b73b4e7c3d5 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Wed, 15 Oct 2025 14:23:05 -0400 Subject: [PATCH 44/59] feat: PolymorphicSigma.mk' --- HoTTLean/Groupoids/Pi.lean | 153 ++-- HoTTLean/Groupoids/Sigma copy.lean | 1036 +++++++++++++++++++++++++ HoTTLean/Groupoids/Sigma.lean | 100 +-- HoTTLean/Model/StructuredModel.lean | 1 - HoTTLean/Model/UnstructuredModel.lean | 141 +++- 5 files changed, 1280 insertions(+), 151 deletions(-) create mode 100644 HoTTLean/Groupoids/Sigma copy.lean diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index 9ac367f2..ab2c2e0c 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -452,33 +452,33 @@ def mapStrongTrans : ∫ A ⥤ ∫ sigma A B := Pseudofunctor.Grothendieck.map (strongTrans B s hs) ⋙ Functor.Grothendieck.toPseudoFunctor'Iso.inv _ -lemma _root_.CategoryTheory.Functor.Grothendieck.toPseudofunctor'Iso_inv_map {Γ : Type*} - [Category Γ] (F G : Γ ⥤ Cat) (α : F ⟶ G) : - Functor.Grothendieck.toPseudoFunctor'Iso.inv F ⋙ Functor.Grothendieck.map α = - Pseudofunctor.Grothendieck.map α.toStrongTrans' ⋙ - Functor.Grothendieck.toPseudoFunctor'Iso.inv G := - sorry +-- lemma _root_.CategoryTheory.Functor.Grothendieck.toPseudofunctor'Iso_inv_map {Γ : Type*} +-- [Category Γ] (F G : Γ ⥤ Cat) (α : F ⟶ G) : +-- Functor.Grothendieck.toPseudoFunctor'Iso.inv F ⋙ Functor.Grothendieck.map α = +-- Pseudofunctor.Grothendieck.map α.toStrongTrans' ⋙ +-- Functor.Grothendieck.toPseudoFunctor'Iso.inv G := +-- sorry -section +-- section -variable {𝒮 : Type u₁} {𝒮' : Type u₂} [Category.{v₁} 𝒮] [Category.{v₂} 𝒮'] - (F : Pseudofunctor (LocallyDiscrete 𝒮) Cat.{v₂, u₂}) - (G : Pseudofunctor (LocallyDiscrete 𝒮') (LocallyDiscrete 𝒮)) +-- variable {𝒮 : Type u₁} {𝒮' : Type u₂} [Category.{v₁} 𝒮] [Category.{v₂} 𝒮'] +-- (F : Pseudofunctor (LocallyDiscrete 𝒮) Cat.{v₂, u₂}) +-- (G : Pseudofunctor (LocallyDiscrete 𝒮') (LocallyDiscrete 𝒮)) -open Pseudofunctor.Grothendieck +-- open Pseudofunctor.Grothendieck -def _root_.CategoryTheory.Pseudofunctor.Grothendieck.pre : - ∫ G.comp F ⥤ ∫ F := sorry +-- def _root_.CategoryTheory.Pseudofunctor.Grothendieck.pre : +-- ∫ G.comp F ⥤ ∫ F := sorry -end +-- end -lemma _root_.CategoryTheory.Functor.Grothendieck.toPseudofunctor'Iso_inv_pre {Δ : Type u₁} - {Γ : Type u₂} [Category.{v₁} Δ] [Category.{v₂} Γ] (F : Γ ⥤ Cat) (σ : Δ ⥤ Γ) : - Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ F) ⋙ Functor.Grothendieck.pre F σ = - Pseudofunctor.Grothendieck.map (sorry) ⋙ - Pseudofunctor.Grothendieck.pre F.toPseudoFunctor' σ.toPseudoFunctor ⋙ - Functor.Grothendieck.toPseudoFunctor'Iso.inv F := - sorry +-- lemma _root_.CategoryTheory.Functor.Grothendieck.toPseudofunctor'Iso_inv_pre {Δ : Type u₁} +-- {Γ : Type u₂} [Category.{v₁} Δ] [Category.{v₂} Γ] (F : Γ ⥤ Cat) (σ : Δ ⥤ Γ) : +-- Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ F) ⋙ Functor.Grothendieck.pre F σ = +-- Pseudofunctor.Grothendieck.map (sorry) ⋙ +-- Pseudofunctor.Grothendieck.pre F.toPseudoFunctor' σ.toPseudoFunctor ⋙ +-- Functor.Grothendieck.toPseudoFunctor'Iso.inv F := +-- sorry -- lemma _root_.CategoryTheory.Functor.Groupoidal.toPseudoFunctor'Iso_inv_map {Γ : Type*} -- [Groupoid Γ] (F G : Γ ⥤ Grpd) (α : F ⟶ G) : @@ -488,41 +488,41 @@ lemma _root_.CategoryTheory.Functor.Grothendieck.toPseudofunctor'Iso_inv_pre {Δ -- Functor.Grothendieck.toPseudoFunctor'Iso.inv (G ⋙ Grpd.forgetToCat) := -- Functor.Grothendieck.toPseudoFunctor'Iso_inv_map .. -lemma mapStrongTrans_comp : - mapStrongTrans (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) ⋙ - map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ = - pre A σ ⋙ mapStrongTrans B s hs := - calc mapStrongTrans (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) ⋙ - map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ - _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ - Pseudofunctor.Grothendieck.map (strongTrans (pre A σ ⋙ B) (σ ⋙ s) - (by simp [Functor.assoc, hs, pi_naturality])) ⋙ - (Pseudofunctor.Grothendieck.map (NatTrans.toStrongTrans' _ _ - (eqToHom (by rw [← Functor.assoc, sigma_naturality]))) ⋙ - Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ sigma A B ⋙ Grpd.forgetToCat)) ⋙ - pre (sigma A B) σ := by - rw [mapStrongTrans, ← Functor.assoc, ← Functor.Grothendieck.toPseudofunctor'Iso_inv_map] - simp [Functor.Groupoidal, Functor.Groupoidal.map, Functor.assoc] - _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ - Pseudofunctor.Grothendieck.map (strongTrans (pre A σ ⋙ B) (σ ⋙ s) - (by simp [Functor.assoc, hs, pi_naturality])) ⋙ - Pseudofunctor.Grothendieck.map (NatTrans.toStrongTrans' _ _ - (eqToHom (by rw [← Functor.assoc, sigma_naturality]))) ⋙ - Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ sigma A B ⋙ Grpd.forgetToCat) ⋙ - pre (sigma A B) σ := by - simp [Functor.assoc] - -- _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ - -- Pseudofunctor.Grothendieck.map (Oplax.StrongTrans.comp (strongTrans (pre A σ ⋙ B) (σ ⋙ s) sorry) sorry) ⋙ - -- Pseudofunctor.Grothendieck.pre (sigma A B ⋙ - -- Grpd.forgetToCat).toPseudoFunctor' σ.toPseudoFunctor ⋙ - -- Functor.Grothendieck.toPseudoFunctor'Iso.inv (sigma A B ⋙ Grpd.forgetToCat) := by - -- dsimp [pre] - -- rw [Functor.Grothendieck.toPseudofunctor'Iso_inv_pre] - -- simp [Functor.assoc] - -- rw [Pseudofunctor.Grothendieck.map_comp_eq] - -- sorry - _ = pre A σ ⋙ mapStrongTrans B s hs := by - sorry +-- lemma mapStrongTrans_comp : +-- mapStrongTrans (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) ⋙ +-- map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ = +-- pre A σ ⋙ mapStrongTrans B s hs := +-- calc mapStrongTrans (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) ⋙ +-- map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ +-- _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ +-- Pseudofunctor.Grothendieck.map (strongTrans (pre A σ ⋙ B) (σ ⋙ s) +-- (by simp [Functor.assoc, hs, pi_naturality])) ⋙ +-- (Pseudofunctor.Grothendieck.map (NatTrans.toStrongTrans' _ _ +-- (eqToHom (by rw [← Functor.assoc, sigma_naturality]))) ⋙ +-- Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ sigma A B ⋙ Grpd.forgetToCat)) ⋙ +-- pre (sigma A B) σ := by +-- rw [mapStrongTrans, ← Functor.assoc, ← Functor.Grothendieck.toPseudofunctor'Iso_inv_map] +-- simp [Functor.Groupoidal, Functor.Groupoidal.map, Functor.assoc] +-- _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ +-- Pseudofunctor.Grothendieck.map (strongTrans (pre A σ ⋙ B) (σ ⋙ s) +-- (by simp [Functor.assoc, hs, pi_naturality])) ⋙ +-- Pseudofunctor.Grothendieck.map (NatTrans.toStrongTrans' _ _ +-- (eqToHom (by rw [← Functor.assoc, sigma_naturality]))) ⋙ +-- Functor.Grothendieck.toPseudoFunctor'Iso.inv (σ ⋙ sigma A B ⋙ Grpd.forgetToCat) ⋙ +-- pre (sigma A B) σ := by +-- simp [Functor.assoc] +-- -- _ = Functor.Grothendieck.toPseudoFunctor'Iso.hom ((σ ⋙ A) ⋙ Grpd.forgetToCat) ⋙ +-- -- Pseudofunctor.Grothendieck.map (Oplax.StrongTrans.comp (strongTrans (pre A σ ⋙ B) (σ ⋙ s) sorry) sorry) ⋙ +-- -- Pseudofunctor.Grothendieck.pre (sigma A B ⋙ +-- -- Grpd.forgetToCat).toPseudoFunctor' σ.toPseudoFunctor ⋙ +-- -- Functor.Grothendieck.toPseudoFunctor'Iso.inv (sigma A B ⋙ Grpd.forgetToCat) := by +-- -- dsimp [pre] +-- -- rw [Functor.Grothendieck.toPseudofunctor'Iso_inv_pre] +-- -- simp [Functor.assoc] +-- -- rw [Pseudofunctor.Grothendieck.map_comp_eq] +-- -- sorry +-- _ = pre A σ ⋙ mapStrongTrans B s hs := by +-- sorry /-- Let `Γ` be a category. For any pair of functors `A : Γ ⥤ Grpd` and `B : ∫(A) ⥤ Grpd`, @@ -565,14 +565,14 @@ lemma ι_comp_inversion {x} : ι A x ⋙ inversion B s hs = · intro a b h sorry -lemma inversion_comp : pi.inversion (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) = - pre A σ ⋙ pi.inversion B s hs := by - dsimp [inversion] - rw [← pre_toPGrpd] - conv => left; right; rw [← Functor.assoc, sigma.assoc_pre] - simp only [← Functor.assoc] - congr 2 - rw [Functor.assoc, mapStrongTrans_comp] +-- lemma inversion_comp : pi.inversion (pre A σ ⋙ B) (σ ⋙ s) (by simp [Functor.assoc, hs, pi_naturality]) = +-- pre A σ ⋙ pi.inversion B s hs := by +-- dsimp [inversion] +-- rw [← pre_toPGrpd] +-- conv => left; right; rw [← Functor.assoc, sigma.assoc_pre] +-- simp only [← Functor.assoc] +-- congr 2 +-- rw [Functor.assoc, mapStrongTrans_comp] end @@ -1004,18 +1004,18 @@ def unLam {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (f : Γ ⟶ U. rw [← toCoreAsSmallEquiv_apply_comp_right, f_tp] simp [Pi]) -lemma unLam_comp {Γ Δ : Ctx.{max u (v+1)}} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} - (eq : σ ≫ A = σA) {B : U.ext A ⟶ U.Ty} (f : Γ ⟶ U.Tm) - (f_tp : f ≫ U.tp = UPi.Pi B) : UPi.unLam (U.substWk σ A σA eq ≫ B) (σ ≫ f) - (by rw [Category.assoc, f_tp, Pi_comp]) = U.substWk σ A σA eq ≫ UPi.unLam B f f_tp := by - dsimp [unLam] - rw [← toCoreAsSmallEquiv_symm_apply_comp_left] - congr 1 - subst eq - conv => right; rw! [U.substWk_eq, Functor.assoc] - simp [map_id_eq, U.substWk_eq] - rw [← pi.inversion_comp] - rfl +-- lemma unLam_comp {Γ Δ : Ctx.{max u (v+1)}} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} +-- (eq : σ ≫ A = σA) {B : U.ext A ⟶ U.Ty} (f : Γ ⟶ U.Tm) +-- (f_tp : f ≫ U.tp = UPi.Pi B) : UPi.unLam (U.substWk σ A σA eq ≫ B) (σ ≫ f) +-- (by rw [Category.assoc, f_tp, Pi_comp]) = U.substWk σ A σA eq ≫ UPi.unLam B f f_tp := by +-- dsimp [unLam] +-- rw [← toCoreAsSmallEquiv_symm_apply_comp_left] +-- congr 1 +-- subst eq +-- conv => right; rw! [U.substWk_eq, Functor.assoc] +-- simp [map_id_eq, U.substWk_eq] +-- rw [← pi.inversion_comp] +-- rfl 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 @@ -1048,7 +1048,6 @@ def UPi : Model.UnstructuredUniverse.PolymorphicPi U.{v} U.{v} U.{v} where lam_comp _ _ _ _ _ _ _ := UPi.lam_comp .. lam_tp := UPi.lam_tp unLam := UPi.unLam - unLam_comp := UPi.unLam_comp unLam_tp := UPi.unLam_tp unLam_lam := UPi.unLam_lam lam_unLam := UPi.lam_unLam diff --git a/HoTTLean/Groupoids/Sigma copy.lean b/HoTTLean/Groupoids/Sigma copy.lean new file mode 100644 index 00000000..ebfc245c --- /dev/null +++ b/HoTTLean/Groupoids/Sigma copy.lean @@ -0,0 +1,1036 @@ +import HoTTLean.Groupoids.UnstructuredModel +import HoTTLean.ForMathlib.CategoryTheory.RepPullbackCone + +universe v u v₁ u₁ v₂ u₂ v₃ u₃ + +noncomputable section + +namespace GroupoidModel + +open CategoryTheory Model UnstructuredUniverse Opposite Functor.Groupoidal PGrpd + +attribute [local simp] eqToHom_map Grpd.id_eq_id Grpd.comp_eq_comp Functor.id_comp + +namespace FunctorOperation + +section +variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} + (B : ∫ A ⥤ Grpd.{v₁,u₁}) (x : Γ) +/-- +For a point `x : Γ`, `(sigma A B).obj x` is the groupoidal Grothendieck + construction on the composition + `ι _ x ⋙ B : A.obj x ⥤ Groupoidal A ⥤ Grpd` +-/ +def sigmaObj : Grpd := Grpd.of (∫ι A x ⋙ B) + +variable {x} {y : Γ} (f : x ⟶ y) +/-- +For a morphism `f : x ⟶ y` in `Γ`, `(sigma A B).map y` is a +composition of functors. +The first functor `map (whiskerRight (ιNatTrans f) B)` +is an equivalence which replaces `ι A x` with the naturally +isomorphic `A.map f ⋙ ι A y`. +The second functor is the action of precomposing +`A.map f` with `ι A y ⋙ B` on the Grothendieck constructions. + + map ⋯ pre ⋯ + ∫ ι A x ⋙ B ⥤ ∫ A.map f ⋙ ι A y ⋙ B ⥤ ∫ ι A y ⋙ B +-/ +def sigmaMap : sigmaObj B x ⥤ sigmaObj B y := + map (Functor.whiskerRight (ιNatTrans f) B) ⋙ pre (ι A y ⋙ B) (A.map f) + +@[simp] theorem sigmaMap_obj_base (a) : + ((sigmaMap B f).obj a).base = (A.map f).obj a.base := + rfl + +@[simp] theorem sigmaMap_obj_fiber (a) : + ((sigmaMap B f).obj a).fiber = (B.map ((ιNatTrans f).app a.base)).obj (a.fiber) := rfl + +theorem ιNatTrans_app_base (a : sigmaObj B x) : ((ιNatTrans f).app a.base) = homMk f (𝟙 (A.map f).obj a.base) := + rfl + +@[simp] theorem sigmaMap_map_base {a b : sigmaObj B x} {p : a ⟶ b} : + ((sigmaMap B f).map p).base = (A.map f).map p.base := rfl + +theorem sigmaMap_map_fiber_aux {a b : sigmaObj B x} {p : a ⟶ b} : + (((ι A y ⋙ B)).map ((sigmaMap B f).map p).base).obj ((sigmaMap B f).obj a).fiber = + (B.map ((ιNatTrans f).app (base b))).obj (((ι A x ⋙ B).map p.base).obj a.fiber) := by + simp only [sigmaObj, sigmaMap, Functor.comp_obj, Functor.comp_map, pre_map_base, map_map_base, + pre_obj_fiber, map_obj_fiber, Functor.whiskerRight_app] + simp only [← Functor.comp_obj, ← Grpd.comp_eq_comp, ← Functor.map_comp] + congr 2 + exact ((ιNatTrans f).naturality p.base).symm + +@[simp] theorem sigmaMap_map_fiber {a b : sigmaObj B x} {p : a ⟶ b} : + ((sigmaMap B f).map p).fiber = + eqToHom (sigmaMap_map_fiber_aux B f) ≫ (B.map ((ιNatTrans f).app (base b))).map p.fiber := by + simp only [sigmaObj, sigmaMap, Functor.comp_obj, Functor.comp_map, + pre_map_fiber, map_map_fiber, Functor.whiskerRight_app] + +variable {B} + +@[simp] theorem sigmaMap_id_obj {p} : (sigmaMap B (𝟙 x)).obj p = p := by + apply hext + · simp [sigmaMap] + · simp [sigmaMap, Grpd.eqToHom_obj] + +@[simp] theorem sigmaMap_id_map {p1 p2} {hp2 : p2 = (sigmaMap B (𝟙 x)).obj p2} + (f : p1 ⟶ p2) : + (sigmaMap B (𝟙 x)).map f = + eqToHom (by simp) ≫ f ≫ eqToHom (by simp) := by + have h (a : A.obj x) : B.map ((ιNatTrans (𝟙 x)).app a) = + eqToHom (by simp) := + calc + B.map ((ιNatTrans (𝟙 x)).app a) + _ = B.map (eqToHom (by simp)) := by + rw [ιNatTrans_id_app] + _ = eqToHom (by simp) := by + simp + have h1 : B.map ((ι A x).map (eqToHom hp2).base) = eqToHom (by simp) := by + simp [sigmaObj, base_eqToHom] + fapply Hom.ext + · simp [sigmaObj, sigmaMap] + · simp [sigmaObj, sigmaMap_map_fiber, Functor.congr_hom (h p2.base) f.fiber, + Functor.congr_hom h1] + +@[simp] theorem sigmaMap_id : sigmaMap B (𝟙 x) = 𝟭 _ := by + apply CategoryTheory.Functor.ext + · intro p1 p2 f + simp + · intro p + simp + +variable {z : Γ} {f} {g : y ⟶ z} + +@[simp] theorem sigmaMap_comp_obj {p} : (sigmaMap B (f ≫ g)).obj p = + (sigmaMap B g).obj ((sigmaMap B f).obj p) := by + dsimp only [sigmaMap] + apply hext + · simp + · simp only [sigmaObj, Functor.comp_obj, pre_obj_fiber, map_obj_fiber, Functor.whiskerRight_app, + ιNatTrans_comp_app, Functor.map_comp, eqToHom_map, Grpd.comp_eq_comp, Grpd.eqToHom_obj, cast_heq_iff_heq, heq_eq_eq] + aesop_cat + +@[simp] theorem sigmaMap_comp_map {A : Γ ⥤ Grpd.{v₁,u₁}} + {B : ∫(A) ⥤ Grpd.{v₁,u₁}} {x y z : Γ} {f : x ⟶ y} {g : y ⟶ z} + {p q : sigmaObj B x} (hpq : p ⟶ q) + {h1 : (sigmaMap B (f ≫ g)).obj p = (sigmaMap B g).obj ((sigmaMap B f).obj p)} + {h2 : (sigmaMap B g).obj ((sigmaMap B f).obj q) = (sigmaMap B (f ≫ g)).obj q} + : (sigmaMap B (f ≫ g)).map hpq = + eqToHom h1 ≫ (sigmaMap B g).map ((sigmaMap B f).map hpq) ≫ eqToHom h2 := by + have h : B.map ((ιNatTrans (f ≫ g)).app q.base) = + B.map ((ιNatTrans f).app q.base) + ≫ B.map ((ιNatTrans g).app ((A.map f).obj q.base)) + ≫ eqToHom (by simp) := by simp + fapply Hom.hext + · simp only [sigmaObj, Grpd.coe_of, sigmaMap_obj_base, sigmaMap_map_base, Grpd.map_comp_map, + comp_base, base_eqToHom] + · have h3 : (ι A z ⋙ B).map (eqToHom h2).base + = eqToHom (by simp only [sigmaMap, Functor.comp_obj]; congr 3) := by + rw [base_eqToHom, eqToHom_map] + simp only [sigmaObj, Grpd.coe_of, sigmaMap_obj_base, Functor.comp_obj, sigmaMap_map_base, + Functor.comp_map, sigmaMap_obj_fiber, sigmaMap_map_fiber, Functor.congr_hom h, + Grpd.comp_eq_comp, eqToHom_trans_assoc, comp_base, Functor.Groupoidal.comp_fiber, + fiber_eqToHom, eqToHom_map, Functor.map_comp, Category.assoc, heq_eqToHom_comp_iff, + heq_comp_eqToHom_iff, eqToHom_comp_heq_iff, comp_eqToHom_heq_iff] + rw! (transparency := .default) [Functor.congr_hom h3] + simp only [sigmaObj, Functor.comp_obj, Functor.comp_map, heq_eqToHom_comp_iff, + heq_comp_eqToHom_iff, heq_eq_eq] + +theorem sigmaMap_comp : sigmaMap B (f ≫ g) = sigmaMap B f ⋙ sigmaMap B g := by + apply CategoryTheory.Functor.ext + · intro p q hpq + simp + · intro p + simp + +lemma sigmaMap_forget : sigmaMap B f ⋙ forget = forget ⋙ A.map f := rfl + +/-- The formation rule for Σ-types for the ambient natural model `base` + unfolded into operations between functors. + See `sigmaObj` and `sigmaMap` for the actions of this functor. + -/ +@[simps] def sigma (A : Γ ⥤ Grpd.{v₁,u₁}) + (B : ∫(A) ⥤ Grpd.{v₁,u₁}) : Γ ⥤ Grpd.{v₁,u₁} where + -- NOTE using Grpd.of here instead of earlier speeds things up + obj x := sigmaObj B x + map := sigmaMap B + map_id _ := sigmaMap_id + map_comp _ _ := sigmaMap_comp + +variable (B) {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) +theorem sigma_naturality_aux (x) : + ι (σ ⋙ A) x ⋙ pre A σ ⋙ B = ι A (σ.obj x) ⋙ B := by + rw [← ι_comp_pre] + rfl + +lemma whiskerRight_ιNatTrans_naturality {x y : Δ} (f : x ⟶ y) : + Functor.whiskerRight (ιNatTrans f) (pre A σ ⋙ B) = + eqToHom (sigma_naturality_aux B σ x) ≫ Functor.whiskerRight (ιNatTrans (σ.map f)) B ≫ + eqToHom (by simp [Functor.assoc, sigma_naturality_aux B σ y]) := by + aesop + +lemma sigma_naturality_obj (x) : + Grpd.of (∫ι A (σ.obj x) ⋙ B) + = Grpd.of (∫ι (σ ⋙ A) x ⋙ pre A σ ⋙ B) := by + rw [sigma_naturality_aux] + +lemma sigmaObj_naturality (x) : + sigmaObj B (σ.obj x) = sigmaObj (pre A σ ⋙ B) x := + sigma_naturality_obj _ _ _ + +lemma sigmaMap_naturality {x y : Δ} (f : x ⟶ y) : sigmaMap B (σ.map f) + = Grpd.homOf (map (eqToHom (sigma_naturality_aux B σ x).symm)) ≫ + sigmaMap (pre A σ ⋙ B) f ≫ + Grpd.homOf (map (eqToHom (sigma_naturality_aux B σ y))) := by + have : pre (ι A (σ.obj y) ⋙ B) (A.map (σ.map f)) + = map (eqToHom (by rw[← (sigma_naturality_aux B σ y)])) + ⋙ pre (ι (σ ⋙ A) y ⋙ pre A σ ⋙ B) (A.map (σ.map f)) + ⋙ map (eqToHom (sigma_naturality_aux B σ y)) := by + rw [pre_congr_functor] + dsimp [Grpd.homOf, sigmaMap, ← Functor.assoc] + rw [← map_comp_eq, whiskerRight_ιNatTrans_naturality] + simp [map_comp_eq, this, Functor.assoc] + +lemma sigmaMap_naturality_heq {x y : Δ} (f : x ⟶ y) : sigmaMap B (σ.map f) + ≍ sigmaMap (pre A σ ⋙ B) f := by + rw [sigmaMap_naturality] + simp only [sigmaObj, Functor.comp_obj, Grpd.homOf, + ← eqToHom_eq_homOf_map (sigma_naturality_aux B σ x).symm, + ← eqToHom_eq_homOf_map (sigma_naturality_aux B σ y)] + apply HEq.trans (eqToHom_comp_heq _ _) + apply HEq.trans (comp_eqToHom_heq _ _) + rfl + +-- NOTE formerly called `sigmaBeckChevalley` +theorem sigma_naturality : σ ⋙ sigma A B = sigma (σ ⋙ A) (pre A σ ⋙ B) := by + fapply CategoryTheory.Functor.hext + . apply sigmaObj_naturality + . apply sigmaMap_naturality_heq + +end + +section + +variable {Γ : Type u₂} [Category.{v₂} Γ] {α β : Γ ⥤ PGrpd.{v₁,u₁}} + {B : ∫(α ⋙ forgetToGrpd) ⥤ Grpd.{v₁,u₁}} + (h : β ⋙ forgetToGrpd = sec _ α rfl ⋙ B) + +def pairObjFiber (x : Γ) : sigmaObj B x := + objMk (objFiber α x) (objFiber' h x) + +@[simp] theorem pairObjFiber_base (x : Γ) : (pairObjFiber h x).base = objFiber α x := + rfl + +@[simp] theorem pairObjFiber_fiber (x : Γ) : + (pairObjFiber h x).fiber = (objFiber' h x) := + rfl + +theorem pairSectionMap_aux_aux {x y} (f : x ⟶ y) : + (ιNatTrans f).app (pairObjFiber h x).base + ≫ (ι _ y).map (mapFiber α f) + = (sec _ α rfl).map f := by + apply Hom.ext + · simp only [Functor.Groupoidal.comp_fiber, ιNatTrans_app_fiber, ι_obj_fiber, ι_map_fiber, + sec_map_fiber, mapFiber', mapFiber] + rw! (transparency := .default) [CategoryTheory.Functor.map_id, Category.id_comp] + simp [mapFiber'EqToHom] + · simp + +/-- + The left hand side + `mapPairSectionObjFiber h f` is an object in the fiber `sigma A B y` over `y` + The fiber itself consists of bundles, so `(mapPairSectionObjFiber h f).fiber` + is an object in the fiber `B a` for an `a` in the fiber `A y`. + But this `a` is isomorphic to `(pairSectionObjFiber y).base` + and the functor `(ι _ y ⋙ B).map (mapPoint α f)` + converts the data along this isomorphism. + + The right hand side is `(*)` in the diagram. + sec α B + Γ -------> ∫(A) ------------> Grpd + + x (B ⋙ sec α).obj x objPt' h x + | f (B ⋙ sec α).map f | - + V V | + y (B ⋙ sec α).obj y V + (*) +-/ +theorem pairMapFiber_aux {x y} (f : x ⟶ y) : + ((ι _ y ⋙ B).map (mapFiber α f)).obj ((sigmaMap B f).obj (pairObjFiber h x)).fiber = + ((sec _ α rfl ⋙ B).map f).obj (objFiber' h x) := by + simp only [Grpd.forgetToCat.eq_1, Functor.comp_obj, Functor.comp_map, + sigmaObj, sigmaMap, pre_obj_fiber, map_obj_fiber, Functor.whiskerRight_app] + rw [← Grpd.map_comp_obj, pairSectionMap_aux_aux] + rfl + +/-- +This can be thought of as the action of parallel transport on f +or perhaps the path over f, but defined within the fiber over y + + sigma A B x ∋ pairObjFiber h x + | - + | | + | sigma A B f | + | | + V V + sigma A B y ∋ PairMapFiber + _ ⟶ pairObjFiber h y +-/ +def pairMapFiber {x y : Γ} (f : x ⟶ y) : (sigmaMap B f).obj (pairObjFiber h x) + ⟶ (pairObjFiber h y : ∫(ι _ y ⋙ B)) := + homMk (mapFiber α f) (eqToHom (pairMapFiber_aux h f) ≫ mapFiber' h f) + +@[simp↓] theorem pairMapFiber_base {x y} (f : x ⟶ y) : + (pairMapFiber h f).base = mapFiber α f := + rfl + +/- +1. The first implicit argument to `Groupoidal.Hom.fiber` is `(α ⋙ forgetToGrpd).obj y`. + The global `simp` rule `Functor.comp_obj` (which normally fires before this) + rewrites that to `forgetToGrpd.obj (α.obj x)`, + and then this lemma no longer applies. + As a workaround, we instruct `simp` to apply this before visiting subterms. + +2. `@[simps! fiber]` on `pairMapFiber` generates a lemma + that refers to `Grothendieck.Hom.fiber` rather than `Groupoidal.Hom.fiber`, + so we write this by hand. -/ +@[simp↓] theorem pairMapFiber_fiber {x y} (f : x ⟶ y) : + (pairMapFiber h f).fiber = eqToHom (pairMapFiber_aux h f) ≫ mapFiber' h f := + rfl + +theorem pairMapFiber_id (x : Γ) : pairMapFiber h (𝟙 x) = eqToHom (by simp) := by + apply Hom.ext <;> simp [sigmaObj] + +theorem pairMapFiber_comp_aux_aux {x y z} (f : x ⟶ y) (g : y ⟶ z) : + ((ι _ z ⋙ B).map (mapFiber α g)).obj + (((ι _ z ⋙ B ⋙ Grpd.forgetToCat).map + (((sigmaMap B g).map (pairMapFiber h f))).base).obj + ((sigmaMap B g).obj (((sigmaMap B f).obj (pairObjFiber h x)))).fiber) + = ((sec _ α rfl ⋙ B).map f ≫ (sec _ α rfl ⋙ B).map g).obj (objFiber' h x) := by + have h1 : (sec _ α rfl ⋙ B).map f ≫ (sec _ α rfl ⋙ B).map g = (sec _ α rfl ⋙ B).map (f ≫ g) := by + rw [← Functor.map_comp] + rw [Functor.congr_obj h1, ← pairMapFiber_aux,mapFiber_comp, + Functor.map_comp, eqToHom_map, Grpd.comp_eq_comp] + simp only [Functor.comp_obj, Functor.map_comp, Grpd.eqToHom_obj] + congr 2 + have : (sigmaMap B g).obj ((sigmaMap B f).obj (pairObjFiber h x)) + = (sigmaMap B (f ≫ g)).obj (pairObjFiber h x) := by + rw [sigmaMap_comp] + rfl + rw [eq_cast_iff_heq] + congr + +theorem pairMapFiber_comp_aux {x y z} (f : x ⟶ y) (g : y ⟶ z) : + ((ι _ z ⋙ B).map (mapFiber α g)).map ((sigmaMap B g).map (pairMapFiber h f)).fiber + = eqToHom (pairMapFiber_comp_aux_aux h f g) + ≫ ((sec _ α rfl ⋙ B).map g).map (mapFiber' h f) + ≫ eqToHom (by rw [← pairMapFiber_aux]) := by + simp only [Functor.comp_map, sigmaObj, sigmaMap_map_fiber, + Functor.map_comp, eqToHom_map, Category.assoc, eqToHom_trans_assoc, + Grpd.map_comp_map', eqToHom_trans_assoc, eqToHom_comp_iff, comp_eqToHom_iff, + eqToHom_trans_assoc, Category.assoc, eqToHom_trans] + rw! [pairSectionMap_aux_aux] + simp only [pairMapFiber_fiber, Functor.map_comp, eqToHom_refl, Category.comp_id, eqToHom_map] + +-- TODO remove bleedings of `Grothendieck`, e.g. `Grothendieck.forget_obj` +theorem pairMapFiber_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : + (pairMapFiber h (f ≫ g)) = eqToHom (by simp) + ≫ (((sigma (α ⋙ forgetToGrpd) B).map g).map (pairMapFiber h f) ≫ pairMapFiber h g) := by + fapply Hom.ext + · simp [sigmaObj, - Functor.comp_obj, mapFiber] -- FIXME + · rw! (transparency := .default) [pairMapFiber_fiber, Functor.Groupoidal.comp_fiber, Functor.Groupoidal.comp_fiber, + fiber_eqToHom, eqToHom_map, pairMapFiber_comp_aux, + Functor.congr_hom (Functor.congr_hom h.symm g) (mapFiber' h f), mapFiber'_comp] + simp only [sigmaObj, pairMapFiber_fiber, mapFiber', eqToHom_trans_assoc, Category.assoc, + eqToHom_comp_iff, mapFiber'EqToHom] + simp only [← Category.assoc] + congr 1 + simp only [Grpd.coe_of, Grpd.eqToHom_hom, pairObjFiber_base, + Functor.comp_map, Grpd.comp_eq_comp, Category.assoc] + conv => right; right; simp only [← congrArg_cast_hom_left, cast_cast] + rw [conj_eqToHom_iff_heq] + · simp only [heq_cast_iff_heq, cast_heq_iff_heq] + congr 1 + · erw [Functor.congr_obj (Functor.congr_hom h.symm f) (objFiber' h x)] + simp [Grpd.forgetToCat, id_eq, Functor.comp_obj, Functor.comp_map, + Grpd.comp_eq_comp, objFiber', objFiber, + Grpd.eqToHom_obj, cast_cast, cast_eq] + · simp only [objFiber', Functor.comp_obj, objFiber, + Grpd.eqToHom_obj, cast_cast, cast_eq] + · simp only [heq_cast_iff_heq, heq_eq_eq] + · simp [Grpd.eqToHom_obj, Grpd.coe_of, objFiber', Functor.comp_obj, + objFiber, cast_cast, cast_eq] + +variable (α) (β) (B) in +def pair : Γ ⥤ PGrpd.{v₁,u₁} := + PGrpd.functorTo (sigma _ B) (pairObjFiber h) (pairMapFiber h) + (pairMapFiber_id h) (pairMapFiber_comp h) + +@[simp] theorem pair_obj_base (x : Γ) : + ((pair α β B h).obj x).base = ∫(ι (α ⋙ forgetToGrpd) x ⋙ B) := + rfl + +@[simp] theorem pair_obj_fiber (x : Γ) : + ((pair α β B h).obj x).fiber = pairObjFiber h x := + rfl + +@[simp] theorem pair_map_base {x y : Γ} (f : x ⟶ y) : + ((pair α β B h).map f).base = sigmaMap B f := + rfl + +@[simp] theorem pair_map_fiber {x y : Γ} (f : x ⟶ y) : + ((pair α β B h).map f).fiber = pairMapFiber h f := + rfl + +@[simp] theorem pair_comp_forgetToGrpd : + pair α β B h ⋙ forgetToGrpd = sigma (α ⋙ forgetToGrpd) B := rfl + +section + +variable {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) + +include h in +theorem pair_naturality_aux : (σ ⋙ β) ⋙ forgetToGrpd = + sec ((σ ⋙ α) ⋙ forgetToGrpd) (σ ⋙ α) rfl ⋙ pre (α ⋙ forgetToGrpd) σ ⋙ B := by + rw [Functor.assoc, h, ← Functor.assoc, sec_naturality] + rfl + +theorem pair_naturality_ι_pre (x) : + (ι ((σ ⋙ α) ⋙ forgetToGrpd) x ⋙ pre (α ⋙ forgetToGrpd) σ) + = ι (α ⋙ forgetToGrpd) (σ.obj x) := by + apply ι_comp_pre (α ⋙ forgetToGrpd) σ x + +theorem pair_naturality_obj (x : Δ) : HEq (pairObjFiber h (σ.obj x)) + (pairObjFiber (pair_naturality_aux h σ) x) := by + apply hext' + · rw [← Functor.assoc, pair_naturality_ι_pre] + · simp only [heq_eq_eq] + erw [pairObjFiber_base] + · simp only [heq_eq_eq] + erw [pairObjFiber_fiber] + +theorem pair_naturality_aux_1 {x y} (f : x ⟶ y) : + HEq ((sigmaMap B (σ.map f)).obj (pairObjFiber h (σ.obj x))) + ((sigmaMap (pre (α ⋙ forgetToGrpd) σ ⋙ B) f).obj (pairObjFiber (pair_naturality_aux h σ) x)) := by + apply hext' + . apply Eq.symm + calc ι (σ ⋙ α ⋙ forgetToGrpd) y ⋙ pre (α ⋙ forgetToGrpd) σ ⋙ B = + (ι ((σ ⋙ α) ⋙ forgetToGrpd) y ⋙ pre (α ⋙ forgetToGrpd) σ) ⋙ B := by exact + rfl + _ = ι (α ⋙ forgetToGrpd) (σ.obj y) ⋙ B := by rw! [pair_naturality_ι_pre] + . simp only [heq_eq_eq] + erw [sigmaMap_obj_base] + . simp only [heq_eq_eq] + erw [sigmaMap_obj_fiber] + +theorem pair_naturality : σ ⋙ pair α β B h = pair (σ ⋙ α) (σ ⋙ β) (pre (α ⋙ forgetToGrpd) σ ⋙ B) + (by erw [Functor.assoc, h, ← Functor.assoc, sec_naturality, Functor.assoc]) := by + apply PGrpd.Functor.hext + · apply sigma_naturality + · intro x + apply pair_naturality_obj + · intro x y f + apply Hom.hext' + · rw [← Functor.assoc, pair_naturality_ι_pre] + · apply pair_naturality_aux_1 + · apply pair_naturality_obj + · simp [- Functor.comp_obj, - Functor.comp_map, Functor.comp_map, mapFiber_naturality] + · simp [- Functor.comp_obj, - Functor.comp_map, Functor.comp_map, ← mapFiber'_naturality] + +end + +end + +namespace sigma +section +variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) + +@[simps] def fstAux : sigma A B ⟶ A where + app x := Grpd.homOf forget + +lemma fstAux_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : fstAux (pre A σ ⋙ B) = + eqToHom (sigma_naturality ..).symm ≫ Functor.whiskerLeft σ (fstAux B) := by + ext + simp only [sigma_obj, Functor.comp_obj, fstAux_app, NatTrans.comp_app, eqToHom_app, + Functor.whiskerLeft_app, ← heq_eq_eq, heq_eqToHom_comp_iff] + congr + all_goals rw [← Functor.assoc, ι_comp_pre] + +def fstAux' : ∫(sigma A B) ⥤ ∫(A) := + map (fstAux B) + +/-- `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 ⋙ forgetToGrpd = forget ⋙ A := by + dsimp only [fst, fstAux'] + rw [Functor.assoc, (Functor.Groupoidal.isPullback A).comm_sq, + ← Functor.assoc, map_forget] + +-- lemma fst_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : +-- fst (pre A σ ⋙ B) = map (eqToHom (sigma_naturality B σ).symm) ⋙ pre (sigma A B) σ ⋙ fst B := by +-- simp [fst, fstAux'] +-- rw [fstAux_comp, map_comp_eq, ← pre_toPGrpd] +-- rfl -- FIXME: heavy rfl + +end + +section + +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} + (B : ∫(A) ⥤ Grpd.{v₁,u₁}) + +@[simp] def assocFib (x : Γ) : sigmaObj B x ⥤ ∫(B) := + pre _ _ + +def assocIso {x y : Γ} (f : x ⟶ y) : + assocFib B x ≅ sigmaMap B f ⋙ assocFib B y := + preNatIso B (ιNatIso A f) + +@[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] + +theorem assocIso_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : assocIso B (f ≫ g) = + assocIso B f ≪≫ Functor.isoWhiskerLeft (sigmaMap B f) (assocIso B g) + ≪≫ eqToIso (by simp [sigmaMap_comp, Functor.assoc]) := by + simp only [assocFib, sigmaMap, assocIso, preNatIso_congr B (ιNatIso_comp A f g), Iso.trans_hom, + Functor.isoWhiskerLeft_hom, eqToIso.hom, pre_comp, preNatIso_comp, preNatIso_eqToIso, + isoWhiskerLeft_eqToIso, eqToIso_trans, Functor.isoWhiskerLeft_trans, Iso.trans_assoc] + rfl + +def assocHom {x y : Γ} (f : x ⟶ y) : + assocFib B x ⟶ sigmaMap B f ⋙ assocFib B y := + (assocIso B f).hom + +@[simp] theorem assocHom_id {x : Γ} : + assocHom B (𝟙 x) = eqToHom (by simp [sigmaMap_id, Functor.id_comp]) := by + simp [assocHom, assocIso_id] + +theorem assocHom_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : + assocHom B (f ≫ g) = assocHom B f ≫ Functor.whiskerLeft (sigmaMap B f) (assocHom B g) ≫ + eqToHom (by simp [sigmaMap_comp, Functor.assoc]) := by + simp [assocHom, assocIso_comp] + +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 + +def snd : ∫(sigma A B) ⥤ PGrpd := + assoc B ⋙ toPGrpd B + +-- lemma snd_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : snd (A := σ ⋙ A) (pre A σ ⋙ B) = +-- map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ ⋙ snd B := by +-- dsimp [snd] +-- have : toPGrpd (pre A σ ⋙ B) = pre B (pre A σ) ⋙ toPGrpd B := rfl +-- simp only [this, ← Functor.assoc, assoc_pre] + +theorem ι_sigma_comp_map_fstAux (x) : ι (sigma A B) x ⋙ map (fstAux B) + = forget ⋙ ι A x := by + apply FunctorTo.hext + · rw [Functor.assoc, map_forget] + rfl + · intro x + simp + · intro x y f + simp only [sigma_obj, sigmaObj, Functor.comp_obj, ι_obj_base, + Functor.comp_map, ι_map_base, fstAux_app, ι_obj_fiber, + Functor.Groupoidal.forget_obj, map_map_fiber, sigma_map, eqToHom_refl, ι_map_fiber, + Functor.Groupoidal.forget_map, Category.id_comp, heq_eq_eq] + convert comp_base (eqToHom _) f + · rfl + · simp + +theorem functorFromCompFib_assocFib_forget : + functorFromCompFib (assocFib B) forget = asFunctorFromFib (map (fstAux B)) := by + ext x + exact (ι_sigma_comp_map_fstAux B x).symm + +lemma ιNatTrans_app_base_eq {c₁ c₂ : Γ} (f: c₁ ⟶ c₂) (x : ((sigma A B).obj c₁)) : + (ιNatTrans f).app (base x) = (map (fstAux B)).map ((ιNatTrans f).app x) := by + apply Hom.hext + · rfl + · simp only [map_map_fiber, eqToHom_refl, Category.id_comp] + rfl + +theorem assoc_forget : assoc B ⋙ forget = fstAux' B := by + simp only [assoc, fstAux', functorFrom_comp] + rw [← asFunctorFrom (map (fstAux B))] + fapply Functor.Grothendieck.functorFrom_eq_of -- FIXME: bleeding Grothendieck + · exact functorFromCompFib_assocFib_forget B + · intro c₁ c₂ f + rw [comp_eqToHom_iff] + ext x + simp only [NatTrans.comp_app, eqToHom_app, eqToHom_refl, Category.comp_id, Category.id_comp] + apply ιNatTrans_app_base_eq + +theorem snd_forgetToGrpd : snd B ⋙ forgetToGrpd = fstAux' B ⋙ B := + calc + _ = assoc B ⋙ forget ⋙ B := rfl + _ = fstAux' B ⋙ B := by rw [← assoc_forget]; rfl + +@[simp] theorem fst_obj_fiber {x} : ((fst B).obj x).fiber = x.fiber.base := rfl + +@[simp] theorem fst_map_fiber {x y} (f : x ⟶ y) : ((fst B).map f).fiber = f.fiber.base := by + simp [fst, fstAux'] + +@[simp] theorem snd_obj_fiber {x} : ((snd B).obj x).fiber = x.fiber.fiber := by + simp [snd, assoc]; rfl + +@[simp] theorem assoc_hom_app_fiber {x y : ∫(sigma A B)} (f : x ⟶ y) : + (assocHom B (Hom.base f)).app x.fiber + = homMk (homMk f.base (𝟙 _)) (𝟙 _) := by + apply Hom.hext + · apply Hom.hext + · simp [sigmaObj, assocFib, Functor.comp_obj, assocHom, + assocIso, preNatIso_hom_app_base, ιNatIso_hom] + · rw [assocHom, assocIso, preNatIso_hom_app_base, ιNatIso_hom] + simp + rfl + · simp [assocHom, assocIso] + rfl + +-- FIXME: should probably make `snd_map_base` and use that to prove the `eqToHom` +@[simp] theorem snd_map_fiber {x y} (f : x ⟶ y) : ((snd B).map f).fiber = + eqToHom (by simp [snd, assoc]; rfl) ≫ Hom.fiber (Hom.fiber f) := by + simp only [snd, assoc, Functor.comp_map] + rw! [Functor.Groupoidal.functorFrom_map, assoc_hom_app_fiber] + simp only [toPGrpd_map_fiber, Functor.Groupoidal.comp_fiber] + rw! (transparency := .default) [CategoryTheory.Functor.map_id] + simp + +end + +section + +variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) + (αβ : Γ ⥤ PGrpd.{v₁,u₁}) (hαβ : αβ ⋙ forgetToGrpd = sigma A B) + +/-- Let `Γ` be a category. +For any pair of functors `A : Γ ⥤ Grpd` and `B : ∫(A) ⥤ Grpd`, +and any "term of sigma", meaning a functor `αβ : Γ ⥤ PGrpd` +satisfying `αβ ⋙ forgetToGrpd = sigma A B : Γ ⥤ Grpd`, +there is a "term of `A`" `fst' : Γ ⥤ PGrpd` such that `fst ⋙ forgetToGrpd = A`, +thought of as `fst' : A`. +There is a "type" `dependent' : ∫(fst ⋙ forgetToGrpd) ⥤ Grpd`, +which is hequal to `B` modulo `fst ⋙ forgetToGrpd` being equal to `A`. +And there is a "term" `snd' : Γ ⥤ PGrpd` satisfying +`snd' ⋙ forgetToGrpd = sec _ fst rfl ⋙ dependent'`. +-/ +def fst' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ fst B + +@[inherit_doc fst'] theorem fst'_forgetToGrpd : fst' B αβ hαβ ⋙ forgetToGrpd = A := + rfl + +-- lemma fst'_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : +-- fst' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by simp [Functor.assoc, hαβ, sigma_naturality]) = +-- σ ⋙ fst' B αβ hαβ := by +-- dsimp [fst'] +-- conv => right; rw [← Functor.assoc, Functor.Groupoidal.sec_naturality, Functor.assoc] +-- rw! [fst_comp, ← sigma_naturality] +-- simp [map_id_eq] + +@[inherit_doc fst'] def dependent' : ∫(fst' B αβ hαβ ⋙ forgetToGrpd) ⥤ Grpd := + map (eqToHom rfl) ⋙ B + +end + +section +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) + (αβ : Γ ⥤ PGrpd.{v₁,u₁}) (hαβ : αβ ⋙ forgetToGrpd = sigma A B) + +@[inherit_doc fst'] def snd' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ snd B + +-- lemma snd'_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : +-- snd' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by rw [Functor.assoc, hαβ, sigma_naturality]) = +-- σ ⋙ snd' B αβ hαβ := by +-- dsimp [snd'] +-- conv => right; rw [← Functor.assoc, sec_naturality] +-- rw! [snd_comp, ← sigma_naturality] +-- simp [map_id_eq] +-- rfl + +@[simp] theorem fst'_obj_base {x} : ((fst' B αβ hαβ).obj x).base = + A.obj x := rfl + +theorem fst'_obj_fiber {x} : ((fst' B αβ hαβ).obj x).fiber = (objFiber' hαβ x).base := by + simp [fst'] + +@[simp] theorem fst'_map_base {x y} (f : x ⟶ y) : ((fst' B αβ hαβ).map f).base = + A.map f := rfl + +theorem fst'_map_fiber {x y} (f : x ⟶ y) : ((fst' B αβ hαβ).map f).fiber = + (mapFiber' hαβ f).base := by + simp [fst'] + +theorem sec_fstAux' : sec (sigma A B) αβ hαβ ⋙ fstAux' B = + sec (fst' B αβ hαβ ⋙ forgetToGrpd) (fst' B αβ hαβ) rfl := by + apply FunctorTo.hext + · rfl + · intro x + erw [sec_obj_fiber] + rfl + · intro x y f + erw [sec_map_fiber] + simp [fstAux', mapFiber'_rfl, mapFiber, fst'_map_fiber] + +@[inherit_doc fst] theorem snd'_forgetToGrpd : snd' B αβ hαβ ⋙ forgetToGrpd + = sec _ (fst' B αβ hαβ) rfl ⋙ dependent' B αβ hαβ := by + rw [snd', Functor.assoc, snd_forgetToGrpd, dependent', ← Functor.assoc, sec_fstAux'] + simp [map_id_eq, Functor.id_comp] + +theorem snd'_obj_fiber {x} : ((snd' B αβ hαβ).obj x).fiber = (objFiber' hαβ x).fiber := by + simp [snd'] + +-- FIXME: here the `simp` proof should also be factored through a `snd_map_base` +theorem snd'_map_fiber {x y} (f : x ⟶ y) : ((snd' B αβ hαβ).map f).fiber = + eqToHom (by simp [snd', snd, assoc]; rfl) ≫ Hom.fiber (mapFiber' hαβ f) := by + simp [snd'] + +theorem ι_fst'_forgetToGrpd_comp_dependent' (x) : + ι (fst' B αβ hαβ ⋙ forgetToGrpd) x ⋙ dependent' B αβ hαβ = ι A x ⋙ B := by + simp [dependent', map_id_eq, Functor.id_comp, fst'_forgetToGrpd] + +theorem pairObjFiber_snd'_eq (x : Γ) : pairObjFiber (snd'_forgetToGrpd B αβ hαβ) x = + objMk (objFiber' hαβ x).base (objFiber' (snd'_forgetToGrpd B αβ hαβ) x) := by + apply hext + · rw [pairObjFiber_base] + simp [objFiber, fst'_obj_fiber] + · rw [pairObjFiber_fiber] + simp + +theorem pairObjFiber_snd'_heq (x : Γ) : HEq (pairObjFiber (snd'_forgetToGrpd B αβ hαβ) x) + (αβ.obj x).fiber := by + rw [pairObjFiber_snd'_eq] + apply @HEq.trans _ _ _ _ ((objFiber'EqToHom hαβ x).obj (αβ.obj x).fiber) _ ?_ ?_ + · apply hext' + · apply ι_fst'_forgetToGrpd_comp_dependent' + · rfl + · rfl + · simp [Grpd.eqToHom_obj] + +theorem pairMapFiber_snd'_eq {x y} (f : x ⟶ y) : + pairMapFiber (snd'_forgetToGrpd B αβ hαβ) f + = homMk (mapFiber (fst' B αβ hαβ) f) + (eqToHom (pairMapFiber_aux (snd'_forgetToGrpd B αβ hαβ) f) + ≫ mapFiber' (snd'_forgetToGrpd B αβ hαβ) f) := by + apply Hom.hext + · simp + · simp + +theorem pairMapFiber_snd'_heq_src_heq {x y} (f : x ⟶ y) : + HEq ((sigmaMap (dependent' B αβ hαβ) f).obj (pairObjFiber (snd'_forgetToGrpd _ _ hαβ) x)) + ((objFiber'EqToHom hαβ y).obj ((αβ.map f).base.obj (αβ.obj x).fiber)) := by + have h : (αβ.map f).base.obj (αβ.obj x).fiber = _ := + Functor.congr_obj (Functor.congr_hom hαβ f) (αβ.obj x).fiber + rw [Grpd.eqToHom_obj, heq_cast_iff_heq, h] + simp only [Grpd.forgetToCat, dependent', eqToHom_refl, sigmaObj, Functor.comp_obj, + sigma_obj, sigma_map, Grpd.comp_eq_comp, + Grpd.eqToHom_obj, heq_cast_iff_heq] + rw! [map_id_eq] + congr + apply eq_of_heq + rw [heq_cast_iff_heq] + apply HEq.trans _ (pairObjFiber_snd'_heq B αβ hαβ x) + simp only [pairObjFiber, Functor.comp_obj, sigmaObj] + congr + simp [map_id_eq] + +theorem pairMapFiber_snd'_heq_trg_heq {y} : + HEq (pairObjFiber (snd'_forgetToGrpd B αβ hαβ) y) + ((objFiber'EqToHom hαβ y).obj (αβ.obj y).fiber) := by + rw [Grpd.eqToHom_obj, heq_cast_iff_heq] + exact pairObjFiber_snd'_heq B αβ hαβ y + +theorem sigmaMap_obj_objFiber' {x y} (f : x ⟶ y) : (sigmaMap B f).obj (objFiber' hαβ x) = + (objFiber'EqToHom hαβ y).obj ((αβ.map f).base.obj (αβ.obj x).fiber) := by + erw [Functor.congr_obj (Functor.congr_hom hαβ.symm f) (objFiber' hαβ x)] + simp [Grpd.eqToHom_obj, objFiber', objFiber] + +theorem pairMapFiber_snd'_heq {x y} (f : x ⟶ y) : HEq (pairMapFiber (snd'_forgetToGrpd B αβ hαβ) f) + (αβ.map f).fiber := by + rw [pairMapFiber_snd'_eq] + apply @HEq.trans _ _ _ _ ((objFiber'EqToHom hαβ y).map (αβ.map f).fiber) _ ?_ ?_ + · apply Hom.hext' + · apply ι_fst'_forgetToGrpd_comp_dependent' + · apply pairMapFiber_snd'_heq_src_heq + · rw [Grpd.eqToHom_obj, heq_cast_iff_heq] + exact pairObjFiber_snd'_heq B αβ hαβ y + · rw [homMk_base, mapFiber, fst'_map_fiber] + congr! + · apply sigmaMap_obj_objFiber' + · apply HEq.trans (eqToHom_comp_heq _ _) + simp + · simp only [homMk_fiber, eqToHom_comp_heq_iff] + apply HEq.trans (mapFiber'_heq _ f) + simp only [snd'_map_fiber, Functor.comp_map, eqToHom_comp_heq_iff] + congr! + · apply sigmaMap_obj_objFiber' + · apply HEq.trans (eqToHom_comp_heq _ _) + simp + · simp [Grpd.eqToHom_hom] + +theorem eta : pair (fst' B αβ hαβ) (snd' B αβ hαβ) + (dependent' B αβ hαβ) (snd'_forgetToGrpd _ _ _) = αβ := by + apply PGrpd.Functor.hext + · rw [pair, PGrpd.functorTo_forget, hαβ] + congr + simp [dependent', map_id_eq, Functor.id_comp] + · intro x + exact pairObjFiber_snd'_heq _ _ _ _ + · intro x y f + exact pairMapFiber_snd'_heq _ _ _ _ + +end + +section +variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {α β : Γ ⥤ PGrpd.{v₁,u₁}} + {B : ∫(α ⋙ forgetToGrpd) ⥤ Grpd.{v₁,u₁}} (h : β ⋙ forgetToGrpd = sec _ α rfl ⋙ B) + +@[simp] theorem fst'_pair : fst' B (pair α β B h) (pair_comp_forgetToGrpd _) = α := by + apply PGrpd.Functor.hext + · rw [fst'_forgetToGrpd] + · intro x + erw [fst'_obj_fiber] + · intro x y f + simp only [fst'_map_fiber, objFiber'_rfl, mapFiber'_rfl] + erw [pairMapFiber_base, mapFiber] + +@[simp] theorem snd'_pair : snd' B (pair α β B h) (pair_comp_forgetToGrpd _) = β := by + apply PGrpd.Functor.hext + · rw [snd'_forgetToGrpd, h, dependent'] + congr 2 + · rw [fst'_pair] + · simp [map_id_eq, Functor.id_comp] + · intro x + simp only [snd'_obj_fiber, objFiber'_rfl, objFiber, pair_obj_fiber, pairObjFiber_fiber] + simp [objFiber', Grpd.eqToHom_obj, objFiber] + · intro x y f + simp only [snd'_map_fiber] + apply (eqToHom_comp_heq _ _).trans + simp only [sigmaObj, objFiber'_rfl, sigma_obj, Grpd.coe_of, mapFiber', eqToHom_refl, + Grpd.id_eq_id, mapFiber'EqToHom, pair_map_fiber, Functor.id_map, + Functor.Groupoidal.comp_fiber, Functor.Groupoidal.id_fiber, eqToHom_map] + apply (eqToHom_comp_heq _ _).trans + rw [pairMapFiber_fiber] + apply (eqToHom_comp_heq _ _).trans + simp only [mapFiber', mapFiber'EqToHom, Grpd.eqToHom_hom, eqToHom_trans_assoc] + apply (eqToHom_comp_heq _ _).trans + simp + +end + +end sigma + +end FunctorOperation + +open FunctorOperation + +section + +@[simp] +abbrev USig.SigAux {X : Type (v + 1)} [Category.{v} X] + (S : ∀ {Γ : Ctx} (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ X), Γ ⥤ X) + {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ Ctx.coreAsSmall X) : + Γ ⟶ Ctx.coreAsSmall X := + toCoreAsSmallEquiv.symm (S (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv B)) + +theorem USig.SigAux_comp {X : Type (v + 1)} [Category.{v} X] + (S : ∀ {Γ : Ctx} (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ X), Γ ⥤ X) + (S_naturality : ∀ {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⥤ Grpd} + {B : ∫(A) ⥤ X}, σ ⋙ S A B = S (σ ⋙ A) (pre A σ ⋙ B)) + {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} + (eq : σ ≫ A = σA) (B : U.ext A ⟶ Ctx.coreAsSmall X) : + USig.SigAux S (U.substWk σ A σA eq ≫ B) = σ ≫ USig.SigAux S B := by + simp only [USig.SigAux, Grpd.comp_eq_comp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left] + congr 1 + rw [S_naturality] + subst eq + simp only [Grpd.comp_eq_comp] + conv => left; right; rw! [toCoreAsSmallEquiv_apply_comp_left] + rw! (castMode := .all) [toCoreAsSmallEquiv_apply_comp_left] + simp [U.substWk_eq, map_id_eq] + rfl + +def USig.Sig {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := + USig.SigAux sigma B + +/-- +Naturality for the formation rule for Σ-types. +Also known as Beck-Chevalley. +-/ +theorem USig.Sig_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} + (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) : + USig.Sig (U.substWk σ A σA eq ≫ B) = σ ≫ USig.Sig B := + USig.SigAux_comp sigma (by intros; rw [sigma_naturality]) σ eq B + +lemma USig.pair_aux {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + toCoreAsSmallEquiv b ⋙ forgetToGrpd = + sec (toCoreAsSmallEquiv a ⋙ forgetToGrpd) (toCoreAsSmallEquiv a) rfl ⋙ + map (eqToHom (by rw [← a_tp, ← toCoreAsSmallEquiv_apply_comp_right]; rfl)) ⋙ + toCoreAsSmallEquiv B := by + rw [← toCoreAsSmallEquiv_apply_comp_right, ← toCoreAsSmallEquiv_apply_comp_left, + ← toCoreAsSmallEquiv_apply_comp_left] + congr 1 + simp only [Grpd.comp_eq_comp, U.tp] at b_tp + rw [b_tp] + subst a_tp + simp [map_id_eq] + rfl + +def USig.pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + Γ ⟶ U.{v}.Tm := + toCoreAsSmallEquiv.symm <| + FunctorOperation.pair (toCoreAsSmallEquiv a) (toCoreAsSmallEquiv b) + (map (eqToHom (by + rw [← a_tp, ← toCoreAsSmallEquiv_apply_comp_right, Grpd.comp_eq_comp, U.tp])) ⋙ + toCoreAsSmallEquiv B) <| pair_aux B a a_tp b b_tp + +theorem USig.pair_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} + (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + USig.pair (U.substWk σ A σA eq ≫ B) (σ ≫ a) (by cat_disch) (σ ≫ b) + (by rw! [Category.assoc, b_tp, comp_sec_assoc]) = σ ≫ USig.pair B a a_tp b b_tp := by + dsimp [pair] + rw [← toCoreAsSmallEquiv_symm_apply_comp_left, FunctorOperation.pair_naturality] + congr 2 + slice_rhs 2 3 => rw [← toCoreAsSmallEquiv_apply_comp_left] + subst a_tp eq + simp [← toCoreAsSmallEquiv_apply_comp_left, map_id_eq, U.substWk_eq] + rfl + +lemma USig.pair_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + USig.pair B a a_tp b b_tp ≫ U.tp = USig.Sig B := by + dsimp [pair, Sig, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, FunctorOperation.pair_comp_forgetToGrpd, + ← toCoreAsSmallEquiv_apply_comp_left] + subst a_tp + congr 3 + convert_to Grpd.homOf (map (eqToHom _)) ≫ B = 𝟙 (U.ext (a ≫ U.tp)) ≫ B + rw [← eqToHom_eq_homOf_map] + simp + +lemma USig.fst_aux {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : + toCoreAsSmallEquiv s ⋙ forgetToGrpd = sigma (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv B) := by + dsimp only [U.tp, Grpd.comp_eq_comp, Sig] at s_tp + rw [← toCoreAsSmallEquiv_apply_comp_right, s_tp] + simp + +def USig.fst {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : Γ ⟶ U.Tm.{v} := + toCoreAsSmallEquiv.symm <| FunctorOperation.sigma.fst' (toCoreAsSmallEquiv B) + (toCoreAsSmallEquiv s) <| fst_aux B s s_tp + +-- lemma USig.fst_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) +-- (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : +-- USig.fst (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = +-- σ ≫ USig.fst B s s_tp := by +-- dsimp [fst] +-- rw [← toCoreAsSmallEquiv_symm_apply_comp_left, ← sigma.fst'_comp] +-- subst eq +-- rw! [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] +-- simp [map_id_eq] +-- rfl + +lemma USig.fst_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : + USig.fst B s s_tp ≫ U.tp = A := by + dsimp [fst, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, sigma.fst'_forgetToGrpd] + simp + +def USig.snd {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : Γ ⟶ U.Tm.{v} := + toCoreAsSmallEquiv.symm <| FunctorOperation.sigma.snd' (toCoreAsSmallEquiv B) + (toCoreAsSmallEquiv s) <| fst_aux B s s_tp + +-- lemma USig.snd_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) +-- (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : +-- USig.snd (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = +-- σ ≫ USig.snd B s s_tp := by +-- dsimp [snd] +-- rw [← toCoreAsSmallEquiv_symm_apply_comp_left] +-- congr 1 +-- rw [← sigma.snd'_comp] +-- subst eq +-- congr 1 +-- rw [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] +-- simp [map_id_eq] +-- rfl + +def USig.snd_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) + (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : + USig.snd B s s_tp ≫ U.tp = U.sec A (USig.fst B s s_tp) (fst_tp ..) ≫ B := by + dsimp [snd, U.tp] + rw [← toCoreAsSmallEquiv_symm_apply_comp_right, sigma.snd'_forgetToGrpd, + toCoreAsSmallEquiv.symm_apply_eq, toCoreAsSmallEquiv_apply_comp_left] + simp [sigma.dependent', map_id_eq] + rfl + +lemma USig.fst_pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + fst B (USig.pair B a a_tp b b_tp) (pair_tp ..) = a := by + dsimp [fst, pair] + rw [toCoreAsSmallEquiv.symm_apply_eq] + subst a_tp + simp only [Grpd.comp_eq_comp, eqToHom_refl, map_id_eq, Cat.of_α, Functor.id_comp, + Equiv.apply_symm_apply] + exact sigma.fst'_pair (α := toCoreAsSmallEquiv a) (β := toCoreAsSmallEquiv b) + (B := toCoreAsSmallEquiv B) (by rw [pair_aux B a rfl b b_tp]; simp [map_id_eq]; rfl) + +lemma USig.snd_pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) + (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : + USig.snd B (USig.pair B a a_tp b b_tp) (pair_tp ..) = b := by + dsimp [snd, pair] + rw [toCoreAsSmallEquiv.symm_apply_eq] + subst a_tp + simp only [Grpd.comp_eq_comp, eqToHom_refl, map_id_eq, Cat.of_α, Functor.id_comp, + Equiv.apply_symm_apply] + exact sigma.snd'_pair (α := toCoreAsSmallEquiv a) (β := toCoreAsSmallEquiv b) + (B := toCoreAsSmallEquiv B) (by rw [pair_aux B a rfl b b_tp]; simp [map_id_eq]; rfl) + +lemma USig.eta {Γ : Grpd} {A : Γ ⟶ U.Ty} (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) + (s_tp : s ≫ U.tp = USig.Sig B) : + USig.pair B (USig.fst B s s_tp) (fst_tp ..) (USig.snd B s s_tp) (snd_tp ..) = s := by + dsimp [pair] + rw [toCoreAsSmallEquiv.symm_apply_eq] + have h := FunctorOperation.sigma.eta (toCoreAsSmallEquiv B) (toCoreAsSmallEquiv s) + (by rwa [fst_aux]) + simp only [map_id_eq, Cat.of_α, Functor.id_comp] + rw [← h] + congr 1 + simp [sigma.dependent', map_id_eq] + +def USig : PolymorphicSigma U.{v} U.{v} U.{v} where + Sig := USig.Sig + Sig_comp := USig.Sig_comp + pair := USig.pair + pair_comp := USig.pair_comp + pair_tp := USig.pair_tp + fst := USig.fst + -- fst_comp := USig.fst_comp + fst_tp := USig.fst_tp + snd := USig.snd + -- snd_comp := USig.snd_comp + snd_tp := USig.snd_tp + fst_pair := USig.fst_pair + snd_pair := USig.snd_pair + eta := USig.eta + +end + +end GroupoidModel +end diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index fb019f8d..ebfc245c 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -469,11 +469,11 @@ theorem fst_forgetToGrpd : fst B ⋙ forgetToGrpd = forget ⋙ A := by rw [Functor.assoc, (Functor.Groupoidal.isPullback A).comm_sq, ← Functor.assoc, map_forget] -lemma fst_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : - fst (pre A σ ⋙ B) = map (eqToHom (sigma_naturality B σ).symm) ⋙ pre (sigma A B) σ ⋙ fst B := by - simp [fst, fstAux'] - rw [fstAux_comp, map_comp_eq, ← pre_toPGrpd] - rfl -- FIXME: heavy rfl +-- lemma fst_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : +-- fst (pre A σ ⋙ B) = map (eqToHom (sigma_naturality B σ).symm) ⋙ pre (sigma A B) σ ⋙ fst B := by +-- simp [fst, fstAux'] +-- rw [fstAux_comp, map_comp_eq, ← pre_toPGrpd] +-- rfl -- FIXME: heavy rfl end @@ -527,11 +527,11 @@ lemma assoc_pre {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : def snd : ∫(sigma A B) ⥤ PGrpd := assoc B ⋙ toPGrpd B -lemma snd_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : snd (A := σ ⋙ A) (pre A σ ⋙ B) = - map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ ⋙ snd B := by - dsimp [snd] - have : toPGrpd (pre A σ ⋙ B) = pre B (pre A σ) ⋙ toPGrpd B := rfl - simp only [this, ← Functor.assoc, assoc_pre] +-- lemma snd_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : snd (A := σ ⋙ A) (pre A σ ⋙ B) = +-- map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ ⋙ snd B := by +-- dsimp [snd] +-- have : toPGrpd (pre A σ ⋙ B) = pre B (pre A σ) ⋙ toPGrpd B := rfl +-- simp only [this, ← Functor.assoc, assoc_pre] theorem ι_sigma_comp_map_fstAux (x) : ι (sigma A B) x ⋙ map (fstAux B) = forget ⋙ ι A x := by @@ -630,13 +630,13 @@ def fst' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ fst B @[inherit_doc fst'] theorem fst'_forgetToGrpd : fst' B αβ hαβ ⋙ forgetToGrpd = A := rfl -lemma fst'_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : - fst' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by simp [Functor.assoc, hαβ, sigma_naturality]) = - σ ⋙ fst' B αβ hαβ := by - dsimp [fst'] - conv => right; rw [← Functor.assoc, Functor.Groupoidal.sec_naturality, Functor.assoc] - rw! [fst_comp, ← sigma_naturality] - simp [map_id_eq] +-- lemma fst'_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : +-- fst' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by simp [Functor.assoc, hαβ, sigma_naturality]) = +-- σ ⋙ fst' B αβ hαβ := by +-- dsimp [fst'] +-- conv => right; rw [← Functor.assoc, Functor.Groupoidal.sec_naturality, Functor.assoc] +-- rw! [fst_comp, ← sigma_naturality] +-- simp [map_id_eq] @[inherit_doc fst'] def dependent' : ∫(fst' B αβ hαβ ⋙ forgetToGrpd) ⥤ Grpd := map (eqToHom rfl) ⋙ B @@ -649,14 +649,14 @@ variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B @[inherit_doc fst'] def snd' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ snd B -lemma snd'_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : - snd' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by rw [Functor.assoc, hαβ, sigma_naturality]) = - σ ⋙ snd' B αβ hαβ := by - dsimp [snd'] - conv => right; rw [← Functor.assoc, sec_naturality] - rw! [snd_comp, ← sigma_naturality] - simp [map_id_eq] - rfl +-- lemma snd'_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : +-- snd' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by rw [Functor.assoc, hαβ, sigma_naturality]) = +-- σ ⋙ snd' B αβ hαβ := by +-- dsimp [snd'] +-- conv => right; rw [← Functor.assoc, sec_naturality] +-- rw! [snd_comp, ← sigma_naturality] +-- simp [map_id_eq] +-- rfl @[simp] theorem fst'_obj_base {x} : ((fst' B αβ hαβ).obj x).base = A.obj x := rfl @@ -934,16 +934,16 @@ def USig.fst {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) toCoreAsSmallEquiv.symm <| FunctorOperation.sigma.fst' (toCoreAsSmallEquiv B) (toCoreAsSmallEquiv s) <| fst_aux B s s_tp -lemma USig.fst_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) - (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : - USig.fst (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = - σ ≫ USig.fst B s s_tp := by - dsimp [fst] - rw [← toCoreAsSmallEquiv_symm_apply_comp_left, ← sigma.fst'_comp] - subst eq - rw! [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] - simp [map_id_eq] - rfl +-- lemma USig.fst_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) +-- (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : +-- USig.fst (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = +-- σ ≫ USig.fst B s s_tp := by +-- dsimp [fst] +-- rw [← toCoreAsSmallEquiv_symm_apply_comp_left, ← sigma.fst'_comp] +-- subst eq +-- rw! [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] +-- simp [map_id_eq] +-- rfl lemma USig.fst_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : @@ -957,19 +957,19 @@ def USig.snd {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) toCoreAsSmallEquiv.symm <| FunctorOperation.sigma.snd' (toCoreAsSmallEquiv B) (toCoreAsSmallEquiv s) <| fst_aux B s s_tp -lemma USig.snd_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) - (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : - USig.snd (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = - σ ≫ USig.snd B s s_tp := by - dsimp [snd] - rw [← toCoreAsSmallEquiv_symm_apply_comp_left] - congr 1 - rw [← sigma.snd'_comp] - subst eq - congr 1 - rw [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] - simp [map_id_eq] - rfl +-- lemma USig.snd_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) +-- (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : +-- USig.snd (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = +-- σ ≫ USig.snd B s s_tp := by +-- dsimp [snd] +-- rw [← toCoreAsSmallEquiv_symm_apply_comp_left] +-- congr 1 +-- rw [← sigma.snd'_comp] +-- subst eq +-- congr 1 +-- rw [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] +-- simp [map_id_eq] +-- rfl def USig.snd_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : @@ -1021,10 +1021,10 @@ def USig : PolymorphicSigma U.{v} U.{v} U.{v} where pair_comp := USig.pair_comp pair_tp := USig.pair_tp fst := USig.fst - fst_comp := USig.fst_comp + -- fst_comp := USig.fst_comp fst_tp := USig.fst_tp snd := USig.snd - snd_comp := USig.snd_comp + -- snd_comp := USig.snd_comp snd_tp := USig.snd_tp fst_pair := USig.fst_pair snd_pair := USig.snd_pair diff --git a/HoTTLean/Model/StructuredModel.lean b/HoTTLean/Model/StructuredModel.lean index d321eb10..a3c65193 100644 --- a/HoTTLean/Model/StructuredModel.lean +++ b/HoTTLean/Model/StructuredModel.lean @@ -558,7 +558,6 @@ def toUnstructured : 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_comp σ A σA eq _ f f_tp := (P.comp_unLam σ A σA eq _ f f_tp).symm 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 diff --git a/HoTTLean/Model/UnstructuredModel.lean b/HoTTLean/Model/UnstructuredModel.lean index e0fe7e19..65f94a7d 100644 --- a/HoTTLean/Model/UnstructuredModel.lean +++ b/HoTTLean/Model/UnstructuredModel.lean @@ -3,6 +3,7 @@ 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 @@ -29,6 +30,10 @@ 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. -/ @@ -115,6 +120,13 @@ theorem comp_substCons {Θ Δ Γ : Ctx} (τ : Θ ⟶ Δ) (σ : Δ ⟶ Γ) (A : · 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 @@ -137,11 +149,7 @@ def substSnd {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : Δ ⟶ M.Tm theorem substSnd_tp {Δ Γ : Ctx} {A : Γ ⟶ M.Ty} (σ : Δ ⟶ M.ext A) : M.substSnd σ ≫ M.tp = (M.substFst σ) ≫ A := by - simp [substSnd, substFst]; rw [(M.disp_pullback _).w] - -@[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] + simp [substSnd, substFst] /-- Weaken a substitution. @@ -198,13 +206,19 @@ theorem comp_sec {Δ Γ : Ctx} (σ : Δ ⟶ Γ) (A : Γ ⟶ M.Ty) (σA) (eq : σ 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_tp : b ≫ U1.tp = U0.sec A a a_tp ≫ B), - Γ ⟶ U2.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), @@ -215,18 +229,12 @@ structure PolymorphicSigma (U0 U1 U2 : UnstructuredUniverse Ctx) where (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_tp : s ≫ U2.tp = Sig B), Γ ⟶ U0.Tm) - (fst_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} - (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = Sig B), - fst (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by cat_disch) = σ ≫ fst B s s_tp) + (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_tp : s ≫ U2.tp = Sig B), Γ ⟶ U1.Tm) - (snd_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} - (s : Γ ⟶ U2.Tm) (s_tp : s ≫ U2.tp = Sig B), - snd (U0.substWk σ A σA eq ≫ B) (σ ≫ s) (by cat_disch) = σ ≫ snd B s s_tp) + (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) @@ -238,6 +246,83 @@ structure PolymorphicSigma (U0 U1 U2 : UnstructuredUniverse Ctx) where (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), @@ -251,12 +336,8 @@ structure PolymorphicPi (U0 U1 U2 : UnstructuredUniverse Ctx) where (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_tp : f ≫ U2.tp = Pi B), U0.ext A ⟶ U1.Tm) - (unLam_comp : ∀ {Γ Δ} (σ : Δ ⟶ Γ) {A : Γ ⟶ U0.Ty} {σA} (eq) {B : U0.ext A ⟶ U1.Ty} - (f : Γ ⟶ U2.Tm) (f_tp : f ≫ U2.tp = Pi B), - unLam (U0.substWk σ A σA eq ≫ B) (σ ≫ f) (by cat_disch) = - U0.substWk σ A σA eq ≫ unLam B f f_tp) + (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) @@ -264,6 +345,20 @@ structure PolymorphicPi (U0 U1 U2 : UnstructuredUniverse Ctx) where (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 3c0e64421996d33644d25120b5baa04a3b62ffae Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 16 Oct 2025 02:28:27 -0400 Subject: [PATCH 45/59] assoc isomorphism --- .../Bicategory/Grothendieck.lean | 17 +- HoTTLean/ForMathlib/CategoryTheory/Grpd.lean | 11 +- .../CategoryTheory/SplitIsofibration.lean | 32 +- HoTTLean/Grothendieck/Groupoidal/Basic.lean | 17 +- HoTTLean/Groupoids/Pi.lean | 39 +- HoTTLean/Groupoids/Sigma.lean | 978 +++++------------- ...ofibration.lean => SplitIsofibration.lean} | 104 +- HoTTLean/Groupoids/StructuredModel.lean | 8 +- HoTTLean/Groupoids/UnstructuredModel.lean | 2 +- 9 files changed, 400 insertions(+), 808 deletions(-) rename HoTTLean/Groupoids/{SplitClovenIsofibration.lean => SplitIsofibration.lean} (75%) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index 6322c67a..ecacfe96 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean @@ -1258,9 +1258,7 @@ variable (A : E ⥤ C) (fibObj : (x : E) → (A ⋙ F).obj x) (map_comp : {x y z : E} → (f : x ⟶ y) → (g : y ⟶ z) → fibMap (f ≫ g) = eqToHom (functorTo_map_comp_aux A fibObj f g) ≫ (F.map (A.map g)).map (fibMap f) ≫ fibMap g) - -@[simps!] -def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget F) + (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget F) (fibObj_fib_obj : ∀ c x, fibObj ((fib c).obj x) ≍ x) (fibMap_fib_map : ∀ c {x y} (f : x ⟶ y), fibMap ((fib c).map f) ≍ f) (fib_obj_fibObj : ∀ x, (fib (A.obj x)).obj (fibObj x) = x) @@ -1268,8 +1266,10 @@ def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget F) (fib (A.obj y)).map (fibMap f) ≍ f) (obj_fib_obj : ∀ c x, A.obj ((fib c).obj x) = c) (map_hom_app : ∀ {c c'} (f : c ⟶ c') x, A.map ((hom f).app x) ≍ f) - (fibMap_hom_app : ∀ {c c'} (f : c ⟶ c') x, fibMap ((hom f).app x) ≍ 𝟙 ((F.map f).obj x)) : - ∫ F ≅≅ E where + (fibMap_hom_app : ∀ {c c'} (f : c ⟶ c') x, fibMap ((hom f).app x) ≍ 𝟙 ((F.map f).obj x)) + +@[simps!] +def functorIsoFrom : ∫ F ≅≅ E where hom := functorFrom fib hom hom_id hom_comp inv := functorTo A fibObj fibMap map_id map_comp hom_inv_id := by @@ -1301,6 +1301,13 @@ def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget F) · intro x y f simp [← heq_eq_eq, hom_map_app_fibObj] +@[simp] +lemma functorIsoFrom_inv_comp_forget : + (functorIsoFrom fib hom hom_id hom_comp A fibObj fibMap map_id map_comp fib_comp fibObj_fib_obj + fibMap_fib_map fib_obj_fibObj hom_map_app_fibObj obj_fib_obj map_hom_app fibMap_hom_app).inv ⋙ + Grothendieck.forget _ = A := by + simp [functorIsoFrom] + end end diff --git a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean index d0c823da..d889e770 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Grpd.lean @@ -232,7 +232,16 @@ namespace Grpd attribute [simp] comp_eq_comp id_eq_id in @[simps] -def Grpd.mkIso {Δ Γ : Grpd} (F : Δ ≅≅ Γ) : Δ ≅ Γ where +def mkIso {Δ Γ : Grpd} (F : Δ ≅≅ Γ) : Δ ≅ Γ where + hom := F.hom + inv := F.inv + hom_inv_id := by simp + inv_hom_id := by simp + +attribute [simp] comp_eq_comp id_eq_id in +@[simps] +def mkIso' {Δ Γ : Type u} [Groupoid.{v} Δ] [Groupoid.{v} Γ] (F : Δ ≅≅ Γ) : + Grpd.of Δ ≅ Grpd.of Γ where hom := F.hom inv := F.inv hom_inv_id := by simp diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 351effde..5da4cc76 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -108,7 +108,7 @@ lemma ClovenIsofibration.eqToHom_comp_liftIso {X Y : D} (f : X ⟶ Y) [IsIso f] end -structure SplitClovenIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] +structure SplitIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] (F : C ⥤ D) extends ClovenIsofibration F where liftObj_id {X : D} {X' : C} (hX' : F.obj X' = X) : liftObj (𝟙 X) hX' = X' liftIso_id {X : D} {X' : C} (hX' : F.obj X' = X) : liftIso (𝟙 X) hX' = @@ -127,26 +127,26 @@ structure SplitClovenIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] -- I.liftObj f hX' = -namespace SplitClovenIsofibration +namespace SplitIsofibration open ClovenIsofibration @[simp] lemma liftObj_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] - (F : C ⥤ D) (I : SplitClovenIsofibration F) {X Y : D} (h : X = Y) {X' : C} + (F : C ⥤ D) (I : SplitIsofibration F) {X Y : D} (h : X = Y) {X' : C} (hX' : F.obj X' = X) : I.liftObj (eqToHom h) hX' = X' := by subst h simp [liftObj_id] @[simp] lemma liftIso_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] (F : C ⥤ D) - (I : SplitClovenIsofibration F) {X Y : D} (h : X = Y) {X' : C} (hX' : F.obj X' = X) : + (I : SplitIsofibration F) {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 [liftIso_id] variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} - (I : SplitClovenIsofibration F) + (I : SplitIsofibration F) @@ -517,7 +517,7 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E := -- inv_hom_id := sorry def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : - SplitClovenIsofibration F.hom where + SplitIsofibration 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]) @@ -532,13 +532,13 @@ def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : liftIso_comp := by simp liftIso_IsIso := sorry -def id {A : Type u} [Category.{v} A] : SplitClovenIsofibration (𝟭 A) := +def id {A : Type u} [Category.{v} A] : SplitIsofibration (𝟭 A) := iso (Functor.Iso.refl _) section variables {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} - (IF : SplitClovenIsofibration F) {G : B ⥤ C} (IG : SplitClovenIsofibration G) + (IF : SplitIsofibration F) {G : B ⥤ C} (IG : SplitIsofibration G) def comp.liftObj {X Y: C} (f: X ⟶ Y) [i:IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X) : A @@ -597,10 +597,10 @@ lemma comp.liftIso_id {X : C} {X' : A} (hX' : (F ⋙ G).obj X' = X) : simp [← heq_eq_eq] apply HEq.trans (eqToHom_heq_id_dom _ _ _) (eqToHom_heq_id_dom _ _ _).symm - -- have e : (IG.liftIso (𝟙 X) hX') = eqToHom (by simp[SplitClovenIsofibration.liftObj_id]) := by - -- apply SplitClovenIsofibration.liftIso_id + -- have e : (IG.liftIso (𝟙 X) hX') = eqToHom (by simp[SplitIsofibration.liftObj_id]) := by + -- apply SplitIsofibration.liftIso_id - -- --let e:= SplitClovenIsofibration.liftIso_id (X' := F.obj X') + -- --let e:= SplitIsofibration.liftIso_id (X' := F.obj X') -- --rw! (castMode := .all)[liftIso_eqToHom] -- rw! (castMode := .all)[e] -- rw[liftIso_eqToHom] @@ -611,7 +611,7 @@ lemma comp.liftIso_id {X : C} {X' : A} (hX' : (F ⋙ G).obj X' = X) : /-- `IsMultiplicative` 1/2 -/ def comp : - SplitClovenIsofibration (F ⋙ G) where + SplitIsofibration (F ⋙ G) where liftObj := comp.liftObj IF IG liftIso := comp.liftIso IF IG isHomLift := comp.isHomLift IF IG @@ -629,8 +629,8 @@ def comp : /-- `IsStableUnderBaseChange` -/ def ofIsPullback {A B A' B' : 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 : SplitClovenIsofibration F) : - SplitClovenIsofibration F' where + (isPullback : Functor.IsPullback top F' F bot) (IF : SplitIsofibration F) : + SplitIsofibration F' where liftObj := sorry liftIso := sorry isHomLift := sorry @@ -642,8 +642,8 @@ def ofIsPullback {A B A' B' : Type u} [Category.{v} A] [Category.{v} B] [Categor -- 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 : SplitClovenIsofibration F) : --- SplitClovenIsofibration F' where +-- (isPullback : Functor.IsPullback top F' F bot) (IF : SplitIsofibration F) : +-- SplitIsofibration F' where -- liftObj := sorry -- liftIso := sorry -- isHomLift := sorry diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index f111b388..d2ea16ea 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -580,9 +580,7 @@ variable (A : E ⥤ C) (fibObj : (x : E) → (A ⋙ F).obj x) (map_comp : {x y z : E} → (f : x ⟶ y) → (g : y ⟶ z) → fibMap (f ≫ g) = eqToHom (functorTo_map_comp_aux A fibObj f g) ≫ (F.map (A.map g)).map (fibMap f) ≫ fibMap g) - -@[simps!] -def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget) + (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget) (fibObj_fib_obj : ∀ c x, fibObj ((fib c).obj x) ≍ x) (fibMap_fib_map : ∀ c {x y} (f : x ⟶ y), fibMap ((fib c).map f) ≍ f) (fib_obj_fibObj : ∀ x, (fib (A.obj x)).obj (fibObj x) = x) @@ -590,12 +588,21 @@ def functorIsoFrom (fib_comp : ∀ c, fib c ⋙ A = ι F c ⋙ forget) (fib (A.obj y)).map (fibMap f) ≍ f) (obj_fib_obj : ∀ c x, A.obj ((fib c).obj x) = c) (map_hom_app : ∀ {c c'} (f : c ⟶ c') x, A.map ((hom f).app x) ≍ f) - (fibMap_hom_app : ∀ {c c'} (f : c ⟶ c') x, fibMap ((hom f).app x) ≍ 𝟙 ((F.map f).obj x)) : - ∫ F ≅≅ E := + (fibMap_hom_app : ∀ {c c'} (f : c ⟶ c') x, fibMap ((hom f).app x) ≍ 𝟙 ((F.map f).obj x)) + +@[simps!] +def functorIsoFrom : ∫ F ≅≅ E := Grothendieck.functorIsoFrom fib hom hom_id hom_comp A fibObj fibMap map_id map_comp fib_comp fibObj_fib_obj fibMap_fib_map fib_obj_fibObj hom_map_app_fibObj obj_fib_obj map_hom_app fibMap_hom_app +@[simp] +lemma functorIsoFrom_inv_comp_forget : + (functorIsoFrom fib hom hom_id hom_comp A fibObj fibMap map_id map_comp fib_comp fibObj_fib_obj + fibMap_fib_map fib_obj_fibObj hom_map_app_fibObj obj_fib_obj map_hom_app fibMap_hom_app).inv ⋙ + forget = A := + Grothendieck.functorIsoFrom_inv_comp_forget .. + end end end FunctorFrom diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index ab2c2e0c..f704ca0a 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -125,6 +125,7 @@ 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 @@ -530,28 +531,30 @@ 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`. -/ -def inversion : ∫(A) ⥤ PGrpd := mapStrongTrans B s hs ⋙ sigma.assoc B ⋙ toPGrpd B +def inversion : ∫(A) ⥤ PGrpd := mapStrongTrans B s hs ⋙ (sigma.assoc B).inv ⋙ toPGrpd B lemma mapStrongTrans_comp_fstAux' : mapStrongTrans B s hs ⋙ sigma.fstAux' B = 𝟭 _ := by - apply Functor.Groupoidal.FunctorTo.hext - · rw [Functor.assoc, sigma.fstAux', map_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, map_obj_fiber, sigma_obj, sigma.fstAux_app, - Functor.Groupoidal.forget_obj, Functor.id_obj, heq_eq_eq] - exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber - · sorry + sorry + -- apply Functor.Groupoidal.FunctorTo.hext + -- · rw [Functor.assoc, sigma.fstAux', map_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, map_obj_fiber, sigma_obj, sigma.fstAux_app, + -- Functor.Groupoidal.forget_obj, Functor.id_obj, heq_eq_eq] + -- exact Functor.congr_obj (PGrpd.objFiber' hs x.base).property x.fiber + -- · sorry lemma inversion_comp_forgetToGrpd : inversion B s hs ⋙ PGrpd.forgetToGrpd = B := - calc mapStrongTrans B s hs ⋙ sigma.assoc B ⋙ toPGrpd B ⋙ PGrpd.forgetToGrpd - _ = mapStrongTrans B s hs ⋙ (sigma.assoc B ⋙ forget) ⋙ B := by - simp [toPGrpd_forgetToGrpd, Functor.assoc] - _ = mapStrongTrans B s hs ⋙ sigma.fstAux' B ⋙ B := by rw [sigma.assoc_forget] - _ = B := by simp [← Functor.assoc, mapStrongTrans_comp_fstAux'] + sorry + -- calc mapStrongTrans B s hs ⋙ sigma.assoc B ⋙ toPGrpd B ⋙ PGrpd.forgetToGrpd + -- _ = mapStrongTrans B s hs ⋙ (sigma.assoc B ⋙ forget) ⋙ B := by + -- simp [toPGrpd_forgetToGrpd, Functor.assoc] + -- _ = mapStrongTrans B s hs ⋙ sigma.fstAux' B ⋙ B := by rw [sigma.assoc_forget] + -- _ = B := by simp [← Functor.assoc, mapStrongTrans_comp_fstAux'] -- JH: make some API for this? Mixture of Pseudofunctor.Grothendieck -- and Functor.Grothendieck and Functor.Groupoidal is messy. diff --git a/HoTTLean/Groupoids/Sigma.lean b/HoTTLean/Groupoids/Sigma.lean index ebfc245c..028e4fe5 100644 --- a/HoTTLean/Groupoids/Sigma.lean +++ b/HoTTLean/Groupoids/Sigma.lean @@ -210,272 +210,7 @@ theorem sigma_naturality : σ ⋙ sigma A B = sigma (σ ⋙ A) (pre A σ ⋙ B) end -section - -variable {Γ : Type u₂} [Category.{v₂} Γ] {α β : Γ ⥤ PGrpd.{v₁,u₁}} - {B : ∫(α ⋙ forgetToGrpd) ⥤ Grpd.{v₁,u₁}} - (h : β ⋙ forgetToGrpd = sec _ α rfl ⋙ B) - -def pairObjFiber (x : Γ) : sigmaObj B x := - objMk (objFiber α x) (objFiber' h x) - -@[simp] theorem pairObjFiber_base (x : Γ) : (pairObjFiber h x).base = objFiber α x := - rfl - -@[simp] theorem pairObjFiber_fiber (x : Γ) : - (pairObjFiber h x).fiber = (objFiber' h x) := - rfl - -theorem pairSectionMap_aux_aux {x y} (f : x ⟶ y) : - (ιNatTrans f).app (pairObjFiber h x).base - ≫ (ι _ y).map (mapFiber α f) - = (sec _ α rfl).map f := by - apply Hom.ext - · simp only [Functor.Groupoidal.comp_fiber, ιNatTrans_app_fiber, ι_obj_fiber, ι_map_fiber, - sec_map_fiber, mapFiber', mapFiber] - rw! (transparency := .default) [CategoryTheory.Functor.map_id, Category.id_comp] - simp [mapFiber'EqToHom] - · simp - -/-- - The left hand side - `mapPairSectionObjFiber h f` is an object in the fiber `sigma A B y` over `y` - The fiber itself consists of bundles, so `(mapPairSectionObjFiber h f).fiber` - is an object in the fiber `B a` for an `a` in the fiber `A y`. - But this `a` is isomorphic to `(pairSectionObjFiber y).base` - and the functor `(ι _ y ⋙ B).map (mapPoint α f)` - converts the data along this isomorphism. - - The right hand side is `(*)` in the diagram. - sec α B - Γ -------> ∫(A) ------------> Grpd - - x (B ⋙ sec α).obj x objPt' h x - | f (B ⋙ sec α).map f | - - V V | - y (B ⋙ sec α).obj y V - (*) --/ -theorem pairMapFiber_aux {x y} (f : x ⟶ y) : - ((ι _ y ⋙ B).map (mapFiber α f)).obj ((sigmaMap B f).obj (pairObjFiber h x)).fiber = - ((sec _ α rfl ⋙ B).map f).obj (objFiber' h x) := by - simp only [Grpd.forgetToCat.eq_1, Functor.comp_obj, Functor.comp_map, - sigmaObj, sigmaMap, pre_obj_fiber, map_obj_fiber, Functor.whiskerRight_app] - rw [← Grpd.map_comp_obj, pairSectionMap_aux_aux] - rfl - -/-- -This can be thought of as the action of parallel transport on f -or perhaps the path over f, but defined within the fiber over y - - sigma A B x ∋ pairObjFiber h x - | - - | | - | sigma A B f | - | | - V V - sigma A B y ∋ PairMapFiber - _ ⟶ pairObjFiber h y --/ -def pairMapFiber {x y : Γ} (f : x ⟶ y) : (sigmaMap B f).obj (pairObjFiber h x) - ⟶ (pairObjFiber h y : ∫(ι _ y ⋙ B)) := - homMk (mapFiber α f) (eqToHom (pairMapFiber_aux h f) ≫ mapFiber' h f) - -@[simp↓] theorem pairMapFiber_base {x y} (f : x ⟶ y) : - (pairMapFiber h f).base = mapFiber α f := - rfl - -/- -1. The first implicit argument to `Groupoidal.Hom.fiber` is `(α ⋙ forgetToGrpd).obj y`. - The global `simp` rule `Functor.comp_obj` (which normally fires before this) - rewrites that to `forgetToGrpd.obj (α.obj x)`, - and then this lemma no longer applies. - As a workaround, we instruct `simp` to apply this before visiting subterms. - -2. `@[simps! fiber]` on `pairMapFiber` generates a lemma - that refers to `Grothendieck.Hom.fiber` rather than `Groupoidal.Hom.fiber`, - so we write this by hand. -/ -@[simp↓] theorem pairMapFiber_fiber {x y} (f : x ⟶ y) : - (pairMapFiber h f).fiber = eqToHom (pairMapFiber_aux h f) ≫ mapFiber' h f := - rfl - -theorem pairMapFiber_id (x : Γ) : pairMapFiber h (𝟙 x) = eqToHom (by simp) := by - apply Hom.ext <;> simp [sigmaObj] - -theorem pairMapFiber_comp_aux_aux {x y z} (f : x ⟶ y) (g : y ⟶ z) : - ((ι _ z ⋙ B).map (mapFiber α g)).obj - (((ι _ z ⋙ B ⋙ Grpd.forgetToCat).map - (((sigmaMap B g).map (pairMapFiber h f))).base).obj - ((sigmaMap B g).obj (((sigmaMap B f).obj (pairObjFiber h x)))).fiber) - = ((sec _ α rfl ⋙ B).map f ≫ (sec _ α rfl ⋙ B).map g).obj (objFiber' h x) := by - have h1 : (sec _ α rfl ⋙ B).map f ≫ (sec _ α rfl ⋙ B).map g = (sec _ α rfl ⋙ B).map (f ≫ g) := by - rw [← Functor.map_comp] - rw [Functor.congr_obj h1, ← pairMapFiber_aux,mapFiber_comp, - Functor.map_comp, eqToHom_map, Grpd.comp_eq_comp] - simp only [Functor.comp_obj, Functor.map_comp, Grpd.eqToHom_obj] - congr 2 - have : (sigmaMap B g).obj ((sigmaMap B f).obj (pairObjFiber h x)) - = (sigmaMap B (f ≫ g)).obj (pairObjFiber h x) := by - rw [sigmaMap_comp] - rfl - rw [eq_cast_iff_heq] - congr - -theorem pairMapFiber_comp_aux {x y z} (f : x ⟶ y) (g : y ⟶ z) : - ((ι _ z ⋙ B).map (mapFiber α g)).map ((sigmaMap B g).map (pairMapFiber h f)).fiber - = eqToHom (pairMapFiber_comp_aux_aux h f g) - ≫ ((sec _ α rfl ⋙ B).map g).map (mapFiber' h f) - ≫ eqToHom (by rw [← pairMapFiber_aux]) := by - simp only [Functor.comp_map, sigmaObj, sigmaMap_map_fiber, - Functor.map_comp, eqToHom_map, Category.assoc, eqToHom_trans_assoc, - Grpd.map_comp_map', eqToHom_trans_assoc, eqToHom_comp_iff, comp_eqToHom_iff, - eqToHom_trans_assoc, Category.assoc, eqToHom_trans] - rw! [pairSectionMap_aux_aux] - simp only [pairMapFiber_fiber, Functor.map_comp, eqToHom_refl, Category.comp_id, eqToHom_map] - --- TODO remove bleedings of `Grothendieck`, e.g. `Grothendieck.forget_obj` -theorem pairMapFiber_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : - (pairMapFiber h (f ≫ g)) = eqToHom (by simp) - ≫ (((sigma (α ⋙ forgetToGrpd) B).map g).map (pairMapFiber h f) ≫ pairMapFiber h g) := by - fapply Hom.ext - · simp [sigmaObj, - Functor.comp_obj, mapFiber] -- FIXME - · rw! (transparency := .default) [pairMapFiber_fiber, Functor.Groupoidal.comp_fiber, Functor.Groupoidal.comp_fiber, - fiber_eqToHom, eqToHom_map, pairMapFiber_comp_aux, - Functor.congr_hom (Functor.congr_hom h.symm g) (mapFiber' h f), mapFiber'_comp] - simp only [sigmaObj, pairMapFiber_fiber, mapFiber', eqToHom_trans_assoc, Category.assoc, - eqToHom_comp_iff, mapFiber'EqToHom] - simp only [← Category.assoc] - congr 1 - simp only [Grpd.coe_of, Grpd.eqToHom_hom, pairObjFiber_base, - Functor.comp_map, Grpd.comp_eq_comp, Category.assoc] - conv => right; right; simp only [← congrArg_cast_hom_left, cast_cast] - rw [conj_eqToHom_iff_heq] - · simp only [heq_cast_iff_heq, cast_heq_iff_heq] - congr 1 - · erw [Functor.congr_obj (Functor.congr_hom h.symm f) (objFiber' h x)] - simp [Grpd.forgetToCat, id_eq, Functor.comp_obj, Functor.comp_map, - Grpd.comp_eq_comp, objFiber', objFiber, - Grpd.eqToHom_obj, cast_cast, cast_eq] - · simp only [objFiber', Functor.comp_obj, objFiber, - Grpd.eqToHom_obj, cast_cast, cast_eq] - · simp only [heq_cast_iff_heq, heq_eq_eq] - · simp [Grpd.eqToHom_obj, Grpd.coe_of, objFiber', Functor.comp_obj, - objFiber, cast_cast, cast_eq] - -variable (α) (β) (B) in -def pair : Γ ⥤ PGrpd.{v₁,u₁} := - PGrpd.functorTo (sigma _ B) (pairObjFiber h) (pairMapFiber h) - (pairMapFiber_id h) (pairMapFiber_comp h) - -@[simp] theorem pair_obj_base (x : Γ) : - ((pair α β B h).obj x).base = ∫(ι (α ⋙ forgetToGrpd) x ⋙ B) := - rfl - -@[simp] theorem pair_obj_fiber (x : Γ) : - ((pair α β B h).obj x).fiber = pairObjFiber h x := - rfl - -@[simp] theorem pair_map_base {x y : Γ} (f : x ⟶ y) : - ((pair α β B h).map f).base = sigmaMap B f := - rfl - -@[simp] theorem pair_map_fiber {x y : Γ} (f : x ⟶ y) : - ((pair α β B h).map f).fiber = pairMapFiber h f := - rfl - -@[simp] theorem pair_comp_forgetToGrpd : - pair α β B h ⋙ forgetToGrpd = sigma (α ⋙ forgetToGrpd) B := rfl - -section - -variable {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) - -include h in -theorem pair_naturality_aux : (σ ⋙ β) ⋙ forgetToGrpd = - sec ((σ ⋙ α) ⋙ forgetToGrpd) (σ ⋙ α) rfl ⋙ pre (α ⋙ forgetToGrpd) σ ⋙ B := by - rw [Functor.assoc, h, ← Functor.assoc, sec_naturality] - rfl - -theorem pair_naturality_ι_pre (x) : - (ι ((σ ⋙ α) ⋙ forgetToGrpd) x ⋙ pre (α ⋙ forgetToGrpd) σ) - = ι (α ⋙ forgetToGrpd) (σ.obj x) := by - apply ι_comp_pre (α ⋙ forgetToGrpd) σ x - -theorem pair_naturality_obj (x : Δ) : HEq (pairObjFiber h (σ.obj x)) - (pairObjFiber (pair_naturality_aux h σ) x) := by - apply hext' - · rw [← Functor.assoc, pair_naturality_ι_pre] - · simp only [heq_eq_eq] - erw [pairObjFiber_base] - · simp only [heq_eq_eq] - erw [pairObjFiber_fiber] - -theorem pair_naturality_aux_1 {x y} (f : x ⟶ y) : - HEq ((sigmaMap B (σ.map f)).obj (pairObjFiber h (σ.obj x))) - ((sigmaMap (pre (α ⋙ forgetToGrpd) σ ⋙ B) f).obj (pairObjFiber (pair_naturality_aux h σ) x)) := by - apply hext' - . apply Eq.symm - calc ι (σ ⋙ α ⋙ forgetToGrpd) y ⋙ pre (α ⋙ forgetToGrpd) σ ⋙ B = - (ι ((σ ⋙ α) ⋙ forgetToGrpd) y ⋙ pre (α ⋙ forgetToGrpd) σ) ⋙ B := by exact - rfl - _ = ι (α ⋙ forgetToGrpd) (σ.obj y) ⋙ B := by rw! [pair_naturality_ι_pre] - . simp only [heq_eq_eq] - erw [sigmaMap_obj_base] - . simp only [heq_eq_eq] - erw [sigmaMap_obj_fiber] - -theorem pair_naturality : σ ⋙ pair α β B h = pair (σ ⋙ α) (σ ⋙ β) (pre (α ⋙ forgetToGrpd) σ ⋙ B) - (by erw [Functor.assoc, h, ← Functor.assoc, sec_naturality, Functor.assoc]) := by - apply PGrpd.Functor.hext - · apply sigma_naturality - · intro x - apply pair_naturality_obj - · intro x y f - apply Hom.hext' - · rw [← Functor.assoc, pair_naturality_ι_pre] - · apply pair_naturality_aux_1 - · apply pair_naturality_obj - · simp [- Functor.comp_obj, - Functor.comp_map, Functor.comp_map, mapFiber_naturality] - · simp [- Functor.comp_obj, - Functor.comp_map, Functor.comp_map, ← mapFiber'_naturality] - -end - -end - namespace sigma -section -variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) - -@[simps] def fstAux : sigma A B ⟶ A where - app x := Grpd.homOf forget - -lemma fstAux_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : fstAux (pre A σ ⋙ B) = - eqToHom (sigma_naturality ..).symm ≫ Functor.whiskerLeft σ (fstAux B) := by - ext - simp only [sigma_obj, Functor.comp_obj, fstAux_app, NatTrans.comp_app, eqToHom_app, - Functor.whiskerLeft_app, ← heq_eq_eq, heq_eqToHom_comp_iff] - congr - all_goals rw [← Functor.assoc, ι_comp_pre] - -def fstAux' : ∫(sigma A B) ⥤ ∫(A) := - map (fstAux B) - -/-- `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 ⋙ forgetToGrpd = forget ⋙ A := by - dsimp only [fst, fstAux'] - rw [Functor.assoc, (Functor.Groupoidal.isPullback A).comm_sq, - ← Functor.assoc, map_forget] - --- lemma fst_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : --- fst (pre A σ ⋙ B) = map (eqToHom (sigma_naturality B σ).symm) ⋙ pre (sigma A B) σ ⋙ fst B := by --- simp [fst, fstAux'] --- rw [fstAux_comp, map_comp_eq, ← pre_toPGrpd] --- rfl -- FIXME: heavy rfl - -end section @@ -514,318 +249,276 @@ theorem assocHom_comp {x y z : Γ} (f : x ⟶ y) (g : y ⟶ z) : eqToHom (by simp [sigmaMap_comp, Functor.assoc]) := by simp [assocHom, assocIso_comp] -def assoc : ∫(sigma A B) ⥤ ∫(B) := +-- 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 - -def snd : ∫(sigma A B) ⥤ PGrpd := - assoc B ⋙ toPGrpd B - --- lemma snd_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : snd (A := σ ⋙ A) (pre A σ ⋙ B) = --- map (eqToHom (sigma_naturality ..).symm) ⋙ pre (sigma A B) σ ⋙ snd B := by --- dsimp [snd] --- have : toPGrpd (pre A σ ⋙ B) = pre B (pre A σ) ⋙ toPGrpd B := rfl --- simp only [this, ← Functor.assoc, assoc_pre] - -theorem ι_sigma_comp_map_fstAux (x) : ι (sigma A B) x ⋙ map (fstAux B) - = forget ⋙ ι A x := by - apply FunctorTo.hext - · rw [Functor.assoc, map_forget] - rfl - · intro x - simp - · intro x y f - simp only [sigma_obj, sigmaObj, Functor.comp_obj, ι_obj_base, - Functor.comp_map, ι_map_base, fstAux_app, ι_obj_fiber, - Functor.Groupoidal.forget_obj, map_map_fiber, sigma_map, eqToHom_refl, ι_map_fiber, - Functor.Groupoidal.forget_map, Category.id_comp, heq_eq_eq] - convert comp_base (eqToHom _) f - · rfl - · simp - -theorem functorFromCompFib_assocFib_forget : - functorFromCompFib (assocFib B) forget = asFunctorFromFib (map (fstAux B)) := by - ext x - exact (ι_sigma_comp_map_fstAux B x).symm +-- 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 -lemma ιNatTrans_app_base_eq {c₁ c₂ : Γ} (f: c₁ ⟶ c₂) (x : ((sigma A B).obj c₁)) : - (ιNatTrans f).app (base x) = (map (fstAux B)).map ((ιNatTrans f).app x) := by - apply Hom.hext - · rfl - · simp only [map_map_fiber, eqToHom_refl, Category.id_comp] - rfl +section -theorem assoc_forget : assoc B ⋙ forget = fstAux' B := by - simp only [assoc, fstAux', functorFrom_comp] - rw [← asFunctorFrom (map (fstAux B))] - fapply Functor.Grothendieck.functorFrom_eq_of -- FIXME: bleeding Grothendieck - · exact functorFromCompFib_assocFib_forget B - · intro c₁ c₂ f - rw [comp_eqToHom_iff] - ext x - simp only [NatTrans.comp_app, eqToHom_app, eqToHom_refl, Category.comp_id, Category.id_comp] - apply ιNatTrans_app_base_eq - -theorem snd_forgetToGrpd : snd B ⋙ forgetToGrpd = fstAux' B ⋙ B := - calc - _ = assoc B ⋙ forget ⋙ B := rfl - _ = fstAux' B ⋙ B := by rw [← assoc_forget]; rfl - -@[simp] theorem fst_obj_fiber {x} : ((fst B).obj x).fiber = x.fiber.base := rfl - -@[simp] theorem fst_map_fiber {x y} (f : x ⟶ y) : ((fst B).map f).fiber = f.fiber.base := by - simp [fst, fstAux'] - -@[simp] theorem snd_obj_fiber {x} : ((snd B).obj x).fiber = x.fiber.fiber := by - simp [snd, assoc]; rfl - -@[simp] theorem assoc_hom_app_fiber {x y : ∫(sigma A B)} (f : x ⟶ y) : - (assocHom B (Hom.base f)).app x.fiber - = homMk (homMk f.base (𝟙 _)) (𝟙 _) := by - apply Hom.hext - · apply Hom.hext - · simp [sigmaObj, assocFib, Functor.comp_obj, assocHom, - assocIso, preNatIso_hom_app_base, ιNatIso_hom] - · rw [assocHom, assocIso, preNatIso_hom_app_base, ιNatIso_hom] - simp - rfl - · simp [assocHom, assocIso] - rfl +variable {B} --- FIXME: should probably make `snd_map_base` and use that to prove the `eqToHom` -@[simp] theorem snd_map_fiber {x y} (f : x ⟶ y) : ((snd B).map f).fiber = - eqToHom (by simp [snd, assoc]; rfl) ≫ Hom.fiber (Hom.fiber f) := by - simp only [snd, assoc, Functor.comp_map] - rw! [Functor.Groupoidal.functorFrom_map, assoc_hom_app_fiber] - simp only [toPGrpd_map_fiber, Functor.Groupoidal.comp_fiber] - rw! (transparency := .default) [CategoryTheory.Functor.map_id] - simp +@[simp] +def assocFibObj (x : ∫ B) : sigmaObj B x.base.base := + objMk x.base.fiber x.fiber -end +@[simp] theorem assocFibObj_base (x : ∫ B) : (assocFibObj x).base = x.base.fiber := + rfl -section +theorem assocFibMapAux {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 + simp only [assocFibObj, objMk_base, ← Functor.comp_obj, Functor.comp_map, + sigmaMap_obj_fiber, objMk_fiber] + simp only [Functor.comp_obj, ← Grpd.comp_eq_comp, ← Functor.map_comp] + congr 2 + apply Hom.ext <;> simp -variable {Γ : Type u₂} [Category.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) - (αβ : Γ ⥤ PGrpd.{v₁,u₁}) (hαβ : αβ ⋙ forgetToGrpd = sigma A B) - -/-- Let `Γ` be a category. -For any pair of functors `A : Γ ⥤ Grpd` and `B : ∫(A) ⥤ Grpd`, -and any "term of sigma", meaning a functor `αβ : Γ ⥤ PGrpd` -satisfying `αβ ⋙ forgetToGrpd = sigma A B : Γ ⥤ Grpd`, -there is a "term of `A`" `fst' : Γ ⥤ PGrpd` such that `fst ⋙ forgetToGrpd = A`, -thought of as `fst' : A`. -There is a "type" `dependent' : ∫(fst ⋙ forgetToGrpd) ⥤ Grpd`, -which is hequal to `B` modulo `fst ⋙ forgetToGrpd` being equal to `A`. -And there is a "term" `snd' : Γ ⥤ PGrpd` satisfying -`snd' ⋙ forgetToGrpd = sec _ fst rfl ⋙ dependent'`. --/ -def fst' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ fst B +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) -@[inherit_doc fst'] theorem fst'_forgetToGrpd : fst' B αβ hαβ ⋙ forgetToGrpd = A := +@[simp↓] theorem assocFibMap_base {x y : ∫ B} (f : x ⟶ y) : + (assocFibMap f).base = f.base.fiber := rfl --- lemma fst'_comp {Δ : Type u₃} [Category.{v₃} Δ] (σ : Δ ⥤ Γ) : --- fst' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by simp [Functor.assoc, hαβ, sigma_naturality]) = --- σ ⋙ fst' B αβ hαβ := by --- dsimp [fst'] --- conv => right; rw [← Functor.assoc, Functor.Groupoidal.sec_naturality, Functor.assoc] --- rw! [fst_comp, ← sigma_naturality] --- simp [map_id_eq] - -@[inherit_doc fst'] def dependent' : ∫(fst' B αβ hαβ ⋙ forgetToGrpd) ⥤ Grpd := - map (eqToHom rfl) ⋙ B +@[simp↓] theorem assocFibMap_fiber {x y : ∫ B} (f : x ⟶ y) : + (assocFibMap f).fiber = eqToHom (assocFibMapAux ..) ≫ f.fiber := by + rfl -end +lemma assocFibMap_id (x : ∫ B) : assocFibMap (𝟙 x) = eqToHom (by simp) := by + apply Hom.ext <;> simp [sigmaObj] -section -variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {A : Γ ⥤ Grpd.{v₁,u₁}} (B : ∫(A) ⥤ Grpd.{v₁,u₁}) - (αβ : Γ ⥤ PGrpd.{v₁,u₁}) (hαβ : αβ ⋙ forgetToGrpd = sigma A B) +lemma assocFibMap_comp {x y z : ∫ B} (f : x ⟶ y) (g : y ⟶ z) : + assocFibMap (f ≫ g) = eqToHom (by simp) ≫ + (sigmaMap B (Hom.base (Hom.base g))).map (assocFibMap f) ≫ assocFibMap g := by + fapply Hom.ext + · simp only [sigmaObj, Grpd.coe_of, comp_base, assocFibObj, sigmaMap_obj_base, objMk_base, + ↓assocFibMap_base, Functor.Groupoidal.comp_fiber, assocFibMap, Functor.comp_obj, + Functor.comp_map, sigmaMap_obj_fiber, objMk_fiber, base_eqToHom, sigmaMap_map_base, homMk_base] + · simp only [assocFibObj, objMk_base, Functor.comp_obj, comp_base, sigmaMap, ↓assocFibMap_base, + Functor.comp_map, objMk_fiber, ↓assocFibMap_fiber, Functor.Groupoidal.comp_fiber, + eqToHom_trans_assoc, assocFibMap, ← heq_eq_eq, heq_eqToHom_comp_iff, eqToHom_comp_heq_iff] + rw [Functor.Groupoidal.comp_fiber] + simp only [objMk_base, Functor.comp_obj, comp_base, Functor.comp_map, objMk_fiber, + heq_eqToHom_comp_iff] + rw! [fiber_eqToHom, eqToHom_map] + simp only [heq_eqToHom_comp_iff] + rw [Functor.Groupoidal.comp_fiber] + simp only [objMk_base, Functor.comp_obj, comp_base, homMk_base, Functor.comp_map, objMk_fiber, + pre_map_fiber, map_map_fiber, Functor.whiskerRight_app, Grpd.comp_eq_comp, homMk_fiber, + Functor.map_comp, eqToHom_map, eqToHom_trans_assoc, Category.assoc, heq_eqToHom_comp_iff] + have : Hom.base g = (ιNatTrans (Hom.base (Hom.base g))).app y.base.fiber ≫ + (ι A z.base.base).map (Hom.fiber (Hom.base g)) := by + fapply Hom.ext + · simp + · simp + conv => left; rw! (castMode := .all) [this] + simp only [Functor.comp_obj, Grpd.map_comp_map, Category.assoc, eqRec_heq_iff_heq, + eqToHom_comp_heq_iff, heq_eq_eq] + congr 1 + simp [← heq_eq_eq] + rfl -@[inherit_doc fst'] def snd' : Γ ⥤ PGrpd := sec (sigma A B) αβ hαβ ⋙ snd B +lemma assocFib_comp_forget (c : Γ) : assocFib B c ⋙ forget ⋙ + forget = ι (sigma A B) c ⋙ forget := by + dsimp [assocFib] + rw [ι_comp_forget, ← Functor.assoc, pre_comp_forget, Functor.assoc, ι_comp_forget] + aesop_cat --- lemma snd'_comp {Δ : Type u₃} [Groupoid.{v₃} Δ] (σ : Δ ⥤ Γ) : --- snd' (A := σ ⋙ A) (pre A σ ⋙ B) (σ ⋙ αβ) (by rw [Functor.assoc, hαβ, sigma_naturality]) = --- σ ⋙ snd' B αβ hαβ := by --- dsimp [snd'] --- conv => right; rw [← Functor.assoc, sec_naturality] --- rw! [snd_comp, ← sigma_naturality] --- simp [map_id_eq] --- rfl +lemma assocFibObj_assocFib_obj (c : Γ) (x : sigmaObj B c) : + assocFibObj ((assocFib B c).obj x) ≍ x := by + simp only [assocFib, assocFibObj, pre_obj_fiber, heq_eq_eq] + apply Functor.Groupoidal.ext + · simp + · rw! (castMode := .all) [pre_obj_base] + simp -@[simp] theorem fst'_obj_base {x} : ((fst' B αβ hαβ).obj x).base = - A.obj x := rfl +lemma assocFibMap_assocFib_map (c : Γ) {x y : sigmaObj B c} (f : x ⟶ y) : + assocFibMap ((assocFib B c).map f) ≍ f := by + dsimp [assocFib, assocFibMap] + rw! (castMode := .all) [pre_obj_base] + rw! (castMode := .all) [pre_obj_base] + rw! (castMode := .all) [pre_map_base] + apply Hom.hext' <;> simp + +lemma assocFib_forget_comp_forget_obj (x : ∫ B) : + (assocFib B ((forget ⋙ forget).obj x)).obj + (assocFibObj x) = x := by + dsimp [assocFib, assocFibObj] + fapply Functor.Groupoidal.ext + · fapply Functor.Groupoidal.ext + · simp + · rw! (castMode := .all) [pre_obj_base] + simp + · simp -theorem fst'_obj_fiber {x} : ((fst' B αβ hαβ).obj x).fiber = (objFiber' hαβ x).base := by - simp [fst'] +lemma assocHom_app_comp_pre_map_assocFibMap {x y : ∫ B} (f : x ⟶ y) : + (assocHom B (Hom.base (Hom.base f))).app (assocFibObj x) ≫ + (pre B (ι A y.base.base)).map (assocFibMap f) ≍ f := by + dsimp [assocFibObj, assocHom, assocFibMap, assocIso] + fapply Hom.hext' rfl + · simp only [heq_eq_eq] + exact assocFib_forget_comp_forget_obj x + · simp only [heq_eq_eq] + exact assocFib_forget_comp_forget_obj y + · fapply Hom.hext' rfl + · conv => right; rw [← assocFib_forget_comp_forget_obj x] + simp + · conv => right; rw [← assocFib_forget_comp_forget_obj y] + simp + · simp [ιNatIso_hom] + apply Category.comp_id -- FIXME + · simp only [Functor.Groupoidal.comp_base, Functor.Groupoidal.comp_fiber, eqToHom_comp_heq_iff] + rw [preNatIso_hom_app_base, ιNatIso_hom] + rw! (transparency := .default) (castMode := .all) [CategoryTheory.Functor.map_id] + erw [Category.id_comp] + rw! (castMode := .all) [pre_map_base] + simp [- heq_eq_eq] + rfl + · simp -@[simp] theorem fst'_map_base {x y} (f : x ⟶ y) : ((fst' B αβ hαβ).map f).base = - A.map f := rfl +lemma assocFib_comp_forget_comp_forget_obj (c : Γ) (x : sigmaObj B c) : + (assocFib B c ⋙ forget ⋙ forget).obj x = c := by + rfl -theorem fst'_map_fiber {x y} (f : x ⟶ y) : ((fst' B αβ hαβ).map f).fiber = - (mapFiber' hαβ f).base := by - simp [fst'] +lemma forget_comp_forget_map_assocHom_app {c c' : Γ} (f : c ⟶ c') (x : sigmaObj B c) : + (Functor.Groupoidal.forget ⋙ Functor.Groupoidal.forget).map ((assocHom B f).app x) ≍ f := by + rfl -theorem sec_fstAux' : sec (sigma A B) αβ hαβ ⋙ fstAux' B = - sec (fst' B αβ hαβ ⋙ forgetToGrpd) (fst' B αβ hαβ) rfl := by - apply FunctorTo.hext +lemma assocFibMap_assocHom_app {c c' : Γ} (f : c ⟶ c') (x : sigmaObj B c) : + assocFibMap ((assocHom B f).app x) ≍ 𝟙 ((sigmaMap B f).obj x) := by + dsimp [assocFibMap, assocHom, assocIso] + fapply Hom.hext' rfl HEq.rfl HEq.rfl · rfl - · intro x - erw [sec_obj_fiber] - rfl - · intro x y f - erw [sec_map_fiber] - simp [fstAux', mapFiber'_rfl, mapFiber, fst'_map_fiber] - -@[inherit_doc fst] theorem snd'_forgetToGrpd : snd' B αβ hαβ ⋙ forgetToGrpd - = sec _ (fst' B αβ hαβ) rfl ⋙ dependent' B αβ hαβ := by - rw [snd', Functor.assoc, snd_forgetToGrpd, dependent', ← Functor.assoc, sec_fstAux'] - simp [map_id_eq, Functor.id_comp] - -theorem snd'_obj_fiber {x} : ((snd' B αβ hαβ).obj x).fiber = (objFiber' hαβ x).fiber := by - simp [snd'] + · simp only [objMk_base, Functor.comp_obj, sigmaMap_obj_base, homMk_base, Functor.comp_map, + sigmaMap_obj_fiber, objMk_fiber, homMk_fiber, preNatIso_hom_app_fiber, pre_comp, + Category.comp_id, heq_eq_eq] + symm + apply Functor.Groupoidal.id_fiber --- FIXME: here the `simp` proof should also be factored through a `snd_map_base` -theorem snd'_map_fiber {x y} (f : x ⟶ y) : ((snd' B αβ hαβ).map f).fiber = - eqToHom (by simp [snd', snd, assoc]; rfl) ≫ Hom.fiber (mapFiber' hαβ f) := by - simp [snd'] +end -theorem ι_fst'_forgetToGrpd_comp_dependent' (x) : - ι (fst' B αβ hαβ ⋙ forgetToGrpd) x ⋙ dependent' B αβ hαβ = ι A x ⋙ B := by - simp [dependent', map_id_eq, Functor.id_comp, fst'_forgetToGrpd] +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 + assocFib_comp_forget assocFibObj_assocFib_obj assocFibMap_assocFib_map + assocFib_forget_comp_forget_obj assocHom_app_comp_pre_map_assocFibMap + assocFib_comp_forget_comp_forget_obj forget_comp_forget_map_assocHom_app + assocFibMap_assocHom_app -theorem pairObjFiber_snd'_eq (x : Γ) : pairObjFiber (snd'_forgetToGrpd B αβ hαβ) x = - objMk (objFiber' hαβ x).base (objFiber' (snd'_forgetToGrpd B αβ hαβ) x) := by - apply hext - · rw [pairObjFiber_base] - simp [objFiber, fst'_obj_fiber] - · rw [pairObjFiber_fiber] - simp +lemma assoc_hom : (assoc B).hom = Functor.Groupoidal.functorTo (forget ⋙ forget) assocFibObj + assocFibMap assocFibMap_id assocFibMap_comp := + rfl -theorem pairObjFiber_snd'_heq (x : Γ) : HEq (pairObjFiber (snd'_forgetToGrpd B αβ hαβ) x) - (αβ.obj x).fiber := by - rw [pairObjFiber_snd'_eq] - apply @HEq.trans _ _ _ _ ((objFiber'EqToHom hαβ x).obj (αβ.obj x).fiber) _ ?_ ?_ - · apply hext' - · apply ι_fst'_forgetToGrpd_comp_dependent' - · rfl - · rfl - · simp [Grpd.eqToHom_obj] - -theorem pairMapFiber_snd'_eq {x y} (f : x ⟶ y) : - pairMapFiber (snd'_forgetToGrpd B αβ hαβ) f - = homMk (mapFiber (fst' B αβ hαβ) f) - (eqToHom (pairMapFiber_aux (snd'_forgetToGrpd B αβ hαβ) f) - ≫ mapFiber' (snd'_forgetToGrpd B αβ hαβ) f) := by - apply Hom.hext - · simp +lemma assoc_hom_comp_forget : (assoc B).hom ⋙ forget = forget ⋙ forget := by + simp [assoc_hom] + erw [Functor.Groupoidal.functorTo_forget] + +lemma assoc_inv_comp_forget_comp_forget : (assoc B).inv ⋙ forget ⋙ forget + = Functor.Groupoidal.forget := + calc _ + _ = (assoc B).inv ⋙ (assoc B).hom ⋙ Functor.Groupoidal.forget := by + rw [assoc_hom_comp_forget] + _ = _ := by simp + +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 + rw [pre_obj_base, pre_obj_base] + have pre_pre_obj_base_fiber (x) : ((pre B (pre A σ)).obj x).base.fiber = x.base.fiber := by + rw! (castMode := .all) [pre_obj_base, pre_obj_fiber] + simp [assocFibMap] + apply Hom.hext' + · rw [sigma_naturality_aux] + rfl + · simp only [pre_map_base, pre_obj_fiber] + rw! [sigmaMap_naturality] + simp only [Functor.comp_obj, ← eqToHom_eq_homOf_map, Grpd.comp_eq_comp, Grpd.coe_of, + Grpd.eqToHom_obj, cast_heq_iff_heq, heq_eq_eq] + rw! (castMode := .all) [pre_pre_obj_base_fiber] + congr 1 + simp only [← heq_eq_eq, cast_heq_iff_heq] + apply Functor.Groupoidal.hext' + · rw! (castMode := .all) [sigma_naturality_aux, pre_pre_obj_base_base] + · simp + · simp + · apply Functor.Groupoidal.hext' + · rw! (castMode := .all) [sigma_naturality_aux, pre_pre_obj_base_base] + · simp [pre_pre_obj_base_fiber] + · simp + · simp only [sigmaMap_obj_base, objMk_base, homMk_base, Functor.comp_obj, Functor.comp_map] + rfl · simp -theorem pairMapFiber_snd'_heq_src_heq {x y} (f : x ⟶ y) : - HEq ((sigmaMap (dependent' B αβ hαβ) f).obj (pairObjFiber (snd'_forgetToGrpd _ _ hαβ) x)) - ((objFiber'EqToHom hαβ y).obj ((αβ.map f).base.obj (αβ.obj x).fiber)) := by - have h : (αβ.map f).base.obj (αβ.obj x).fiber = _ := - Functor.congr_obj (Functor.congr_hom hαβ f) (αβ.obj x).fiber - rw [Grpd.eqToHom_obj, heq_cast_iff_heq, h] - simp only [Grpd.forgetToCat, dependent', eqToHom_refl, sigmaObj, Functor.comp_obj, - sigma_obj, sigma_map, Grpd.comp_eq_comp, - Grpd.eqToHom_obj, heq_cast_iff_heq] - rw! [map_id_eq] - congr - apply eq_of_heq - rw [heq_cast_iff_heq] - apply HEq.trans _ (pairObjFiber_snd'_heq B αβ hαβ x) - simp only [pairObjFiber, Functor.comp_obj, sigmaObj] - congr - simp [map_id_eq] - -theorem pairMapFiber_snd'_heq_trg_heq {y} : - HEq (pairObjFiber (snd'_forgetToGrpd B αβ hαβ) y) - ((objFiber'EqToHom hαβ y).obj (αβ.obj y).fiber) := by - rw [Grpd.eqToHom_obj, heq_cast_iff_heq] - exact pairObjFiber_snd'_heq B αβ hαβ y - -theorem sigmaMap_obj_objFiber' {x y} (f : x ⟶ y) : (sigmaMap B f).obj (objFiber' hαβ x) = - (objFiber'EqToHom hαβ y).obj ((αβ.map f).base.obj (αβ.obj x).fiber) := by - erw [Functor.congr_obj (Functor.congr_hom hαβ.symm f) (objFiber' hαβ x)] - simp [Grpd.eqToHom_obj, objFiber', objFiber] - -theorem pairMapFiber_snd'_heq {x y} (f : x ⟶ y) : HEq (pairMapFiber (snd'_forgetToGrpd B αβ hαβ) f) - (αβ.map f).fiber := by - rw [pairMapFiber_snd'_eq] - apply @HEq.trans _ _ _ _ ((objFiber'EqToHom hαβ y).map (αβ.map f).fiber) _ ?_ ?_ - · apply Hom.hext' - · apply ι_fst'_forgetToGrpd_comp_dependent' - · apply pairMapFiber_snd'_heq_src_heq - · rw [Grpd.eqToHom_obj, heq_cast_iff_heq] - exact pairObjFiber_snd'_heq B αβ hαβ y - · rw [homMk_base, mapFiber, fst'_map_fiber] - congr! - · apply sigmaMap_obj_objFiber' - · apply HEq.trans (eqToHom_comp_heq _ _) - simp - · simp only [homMk_fiber, eqToHom_comp_heq_iff] - apply HEq.trans (mapFiber'_heq _ f) - simp only [snd'_map_fiber, Functor.comp_map, eqToHom_comp_heq_iff] - congr! - · apply sigmaMap_obj_objFiber' - · apply HEq.trans (eqToHom_comp_heq _ _) - simp - · simp [Grpd.eqToHom_hom] - -theorem eta : pair (fst' B αβ hαβ) (snd' B αβ hαβ) - (dependent' B αβ hαβ) (snd'_forgetToGrpd _ _ _) = αβ := by - apply PGrpd.Functor.hext - · rw [pair, PGrpd.functorTo_forget, hαβ] - congr - simp [dependent', map_id_eq, Functor.id_comp] +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, + map_map_fiber, Functor.Groupoidal.functorTo_obj_base, Functor.Groupoidal.forget_obj, + Functor.Groupoidal.functorTo_map_base, forget_map, Grpd.comp_eq_comp, + Functor.Groupoidal.functorTo_obj_fiber, assocFibObj, Functor.Groupoidal.functorTo_map_fiber, + eqToHom_comp_heq_iff] + rw [Grpd.eqToHom_app, Grpd.eqToHom_hom] + rw! [assocFibMap_pre_pre_map] + simp + +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] + conv => left; right; rw [← Functor.assoc, map_forget] + rw [← Functor.assoc _ forget σ] + conv => left; left; apply Functor.Groupoidal.functorTo_forget + conv => right; right; apply Functor.Groupoidal.functorTo_forget + conv => right; rw [← Functor.assoc, pre_comp_forget] + simp only [Functor.assoc, pre_comp_forget] · intro x - exact pairObjFiber_snd'_heq _ _ _ _ + 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] · intro x y f - exact pairMapFiber_snd'_heq _ _ _ _ + apply assoc_comp_fiber -end +lemma assoc_comp' {Δ : Type u₃} [Groupoid.{v₃} Δ] {σ : Δ ⥤ Γ} (Aσ) (eq : Aσ = σ ⋙ A) : + (sigma.assoc ((map (eqToHom eq) ⋙ pre A σ) ⋙ B)).hom ⋙ + map (eqToHom (by subst eq; simp [sigma_naturality, map_id_eq])) ⋙ pre (sigma A B) σ = + (pre (pre A σ ⋙ B) (map (eqToHom eq)) ⋙ pre B (pre A σ)) ⋙ (sigma.assoc B).hom := by + subst eq + rw! [eqToHom_refl, map_id_eq] + simp [assoc_comp] section -variable {Γ : Type u₂} [Groupoid.{v₂} Γ] {α β : Γ ⥤ PGrpd.{v₁,u₁}} - {B : ∫(α ⋙ forgetToGrpd) ⥤ Grpd.{v₁,u₁}} (h : β ⋙ forgetToGrpd = sec _ α rfl ⋙ B) -@[simp] theorem fst'_pair : fst' B (pair α β B h) (pair_comp_forgetToGrpd _) = α := by - apply PGrpd.Functor.hext - · rw [fst'_forgetToGrpd] - · intro x - erw [fst'_obj_fiber] - · intro x y f - simp only [fst'_map_fiber, objFiber'_rfl, mapFiber'_rfl] - erw [pairMapFiber_base, mapFiber] - -@[simp] theorem snd'_pair : snd' B (pair α β B h) (pair_comp_forgetToGrpd _) = β := by - apply PGrpd.Functor.hext - · rw [snd'_forgetToGrpd, h, dependent'] - congr 2 - · rw [fst'_pair] - · simp [map_id_eq, Functor.id_comp] - · intro x - simp only [snd'_obj_fiber, objFiber'_rfl, objFiber, pair_obj_fiber, pairObjFiber_fiber] - simp [objFiber', Grpd.eqToHom_obj, objFiber] - · intro x y f - simp only [snd'_map_fiber] - apply (eqToHom_comp_heq _ _).trans - simp only [sigmaObj, objFiber'_rfl, sigma_obj, Grpd.coe_of, mapFiber', eqToHom_refl, - Grpd.id_eq_id, mapFiber'EqToHom, pair_map_fiber, Functor.id_map, - Functor.Groupoidal.comp_fiber, Functor.Groupoidal.id_fiber, eqToHom_map] - apply (eqToHom_comp_heq _ _).trans - rw [pairMapFiber_fiber] - apply (eqToHom_comp_heq _ _).trans - simp only [mapFiber', mapFiber'EqToHom, Grpd.eqToHom_hom, eqToHom_trans_assoc] - apply (eqToHom_comp_heq _ _).trans - simp +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] + +end end end sigma @@ -836,21 +529,23 @@ open FunctorOperation section +namespace USig + @[simp] -abbrev USig.SigAux {X : Type (v + 1)} [Category.{v} X] +abbrev SigAux {X : Type (v + 1)} [Category.{v} X] (S : ∀ {Γ : Ctx} (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ X), Γ ⥤ X) {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ Ctx.coreAsSmall X) : Γ ⟶ Ctx.coreAsSmall X := toCoreAsSmallEquiv.symm (S (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv B)) -theorem USig.SigAux_comp {X : Type (v + 1)} [Category.{v} X] +theorem SigAux_comp {X : Type (v + 1)} [Category.{v} X] (S : ∀ {Γ : Ctx} (A : Γ ⥤ Grpd.{v,v}) (B : ∫(A) ⥤ X), Γ ⥤ X) (S_naturality : ∀ {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⥤ Grpd} {B : ∫(A) ⥤ X}, σ ⋙ S A B = S (σ ⋙ A) (pre A σ ⋙ B)) {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) (B : U.ext A ⟶ Ctx.coreAsSmall X) : - USig.SigAux S (U.substWk σ A σA eq ≫ B) = σ ≫ USig.SigAux S B := by - simp only [USig.SigAux, Grpd.comp_eq_comp] + SigAux S (U.substWk σ A σA eq ≫ B) = σ ≫ SigAux S B := by + simp only [SigAux, Grpd.comp_eq_comp] rw [← toCoreAsSmallEquiv_symm_apply_comp_left] congr 1 rw [S_naturality] @@ -861,174 +556,45 @@ theorem USig.SigAux_comp {X : Type (v + 1)} [Category.{v} X] simp [U.substWk_eq, map_id_eq] rfl -def USig.Sig {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := - USig.SigAux sigma B +def Sig {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) : Γ ⟶ U.{v}.Ty := + SigAux sigma B /-- Naturality for the formation rule for Σ-types. Also known as Beck-Chevalley. -/ -theorem USig.Sig_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} +theorem Sig_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) : - USig.Sig (U.substWk σ A σA eq ≫ B) = σ ≫ USig.Sig B := - USig.SigAux_comp sigma (by intros; rw [sigma_naturality]) σ eq B - -lemma USig.pair_aux {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) - (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : - toCoreAsSmallEquiv b ⋙ forgetToGrpd = - sec (toCoreAsSmallEquiv a ⋙ forgetToGrpd) (toCoreAsSmallEquiv a) rfl ⋙ - map (eqToHom (by rw [← a_tp, ← toCoreAsSmallEquiv_apply_comp_right]; rfl)) ⋙ - toCoreAsSmallEquiv B := by - rw [← toCoreAsSmallEquiv_apply_comp_right, ← toCoreAsSmallEquiv_apply_comp_left, - ← toCoreAsSmallEquiv_apply_comp_left] - congr 1 - simp only [Grpd.comp_eq_comp, U.tp] at b_tp - rw [b_tp] - subst a_tp - simp [map_id_eq] - rfl - -def USig.pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) - (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : - Γ ⟶ U.{v}.Tm := - toCoreAsSmallEquiv.symm <| - FunctorOperation.pair (toCoreAsSmallEquiv a) (toCoreAsSmallEquiv b) - (map (eqToHom (by - rw [← a_tp, ← toCoreAsSmallEquiv_apply_comp_right, Grpd.comp_eq_comp, U.tp])) ⋙ - toCoreAsSmallEquiv B) <| pair_aux B a a_tp b b_tp - -theorem USig.pair_comp {Γ Δ : Ctx} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.{v}.Ty} {σA : Δ ⟶ U.Ty} - (eq : σ ≫ A = σA) (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) - (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : - USig.pair (U.substWk σ A σA eq ≫ B) (σ ≫ a) (by cat_disch) (σ ≫ b) - (by rw! [Category.assoc, b_tp, comp_sec_assoc]) = σ ≫ USig.pair B a a_tp b b_tp := by - dsimp [pair] - rw [← toCoreAsSmallEquiv_symm_apply_comp_left, FunctorOperation.pair_naturality] - congr 2 - slice_rhs 2 3 => rw [← toCoreAsSmallEquiv_apply_comp_left] - subst a_tp eq - simp [← toCoreAsSmallEquiv_apply_comp_left, map_id_eq, U.substWk_eq] - rfl - -lemma USig.pair_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) - (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : - USig.pair B a a_tp b b_tp ≫ U.tp = USig.Sig B := by - dsimp [pair, Sig, U.tp] - rw [← toCoreAsSmallEquiv_symm_apply_comp_right, FunctorOperation.pair_comp_forgetToGrpd, - ← toCoreAsSmallEquiv_apply_comp_left] - subst a_tp - congr 3 - convert_to Grpd.homOf (map (eqToHom _)) ≫ B = 𝟙 (U.ext (a ≫ U.tp)) ≫ B - rw [← eqToHom_eq_homOf_map] - simp - -lemma USig.fst_aux {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) - (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : - toCoreAsSmallEquiv s ⋙ forgetToGrpd = sigma (toCoreAsSmallEquiv A) (toCoreAsSmallEquiv B) := by - dsimp only [U.tp, Grpd.comp_eq_comp, Sig] at s_tp - rw [← toCoreAsSmallEquiv_apply_comp_right, s_tp] - simp + Sig (U.substWk σ A σA eq ≫ B) = σ ≫ Sig B := + SigAux_comp sigma (by intros; rw [sigma_naturality]) σ eq B + +def assoc {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) : U.ext B ≅ U.ext (USig.Sig B) := + Grpd.mkIso' (sigma.assoc (toCoreAsSmallEquiv B)) ≪≫ + eqToIso (by dsimp [U.ext, Sig]; rw [toCoreAsSmallEquiv.apply_symm_apply]) + +set_option maxHeartbeats 1000000 in +lemma assoc_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) + (B : U.ext A ⟶ U.Ty) : (USig.assoc (U.substWk σ A σA eq ≫ B)).hom ≫ U.substWk σ (USig.Sig B) + (USig.Sig (U.substWk σ A σA eq ≫ B)) (Sig_comp ..).symm = + U.substWk (U.substWk σ A σA eq) B (U.substWk σ A σA eq ≫ B) rfl ≫ (USig.assoc B).hom := by + dsimp [assoc] + simp only [Sig, SigAux, U.substWk_eq, eqToHom_refl, map_id_eq, Cat.of_α] + rw! (castMode := .all) [toCoreAsSmallEquiv_apply_comp_left] + rw! (castMode := .all) [toCoreAsSmallEquiv.apply_symm_apply] + rw! (castMode := .all) [toCoreAsSmallEquiv.apply_symm_apply] + rw! [U.substWk_eq] + simp only [U_ext, Grpd.homOf, Grpd.comp_eq_comp, Grpd.coe_of, pre_comp, Functor.id_comp] + apply sigma.assoc_comp' (toCoreAsSmallEquiv B) (σ := σ) (toCoreAsSmallEquiv σA) -def USig.fst {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) - (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : Γ ⟶ U.Tm.{v} := - toCoreAsSmallEquiv.symm <| FunctorOperation.sigma.fst' (toCoreAsSmallEquiv B) - (toCoreAsSmallEquiv s) <| fst_aux B s s_tp - --- lemma USig.fst_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) --- (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : --- USig.fst (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = --- σ ≫ USig.fst B s s_tp := by --- dsimp [fst] --- rw [← toCoreAsSmallEquiv_symm_apply_comp_left, ← sigma.fst'_comp] --- subst eq --- rw! [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] --- simp [map_id_eq] --- rfl - -lemma USig.fst_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) - (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : - USig.fst B s s_tp ≫ U.tp = A := by - dsimp [fst, U.tp] - rw [← toCoreAsSmallEquiv_symm_apply_comp_right, sigma.fst'_forgetToGrpd] - simp +lemma assoc_disp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) : + (USig.assoc B).hom ≫ U.disp (USig.Sig B) = U.disp B ≫ U.disp A := by + simpa [assoc] using sigma.assoc_hom_comp_forget _ -def USig.snd {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) - (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : Γ ⟶ U.Tm.{v} := - toCoreAsSmallEquiv.symm <| FunctorOperation.sigma.snd' (toCoreAsSmallEquiv B) - (toCoreAsSmallEquiv s) <| fst_aux B s s_tp - --- lemma USig.snd_comp {Γ Δ : Grpd} (σ : Δ ⟶ Γ) {A : Γ ⟶ U.Ty} {σA : Δ ⟶ U.Ty} (eq : σ ≫ A = σA) --- (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : --- USig.snd (U.substWk σ A σA eq ≫ B) (σ ≫ s) (by rw [Category.assoc, s_tp, Sig_comp]) = --- σ ≫ USig.snd B s s_tp := by --- dsimp [snd] --- rw [← toCoreAsSmallEquiv_symm_apply_comp_left] --- congr 1 --- rw [← sigma.snd'_comp] --- subst eq --- congr 1 --- rw [toCoreAsSmallEquiv_apply_comp_left, U.substWk_eq] --- simp [map_id_eq] --- rfl - -def USig.snd_tp {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.Ty) - (s : Γ ⟶ U.Tm) (s_tp : s ≫ U.tp = USig.Sig B) : - USig.snd B s s_tp ≫ U.tp = U.sec A (USig.fst B s s_tp) (fst_tp ..) ≫ B := by - dsimp [snd, U.tp] - rw [← toCoreAsSmallEquiv_symm_apply_comp_right, sigma.snd'_forgetToGrpd, - toCoreAsSmallEquiv.symm_apply_eq, toCoreAsSmallEquiv_apply_comp_left] - simp [sigma.dependent', map_id_eq] - rfl +end USig -lemma USig.fst_pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) - (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : - fst B (USig.pair B a a_tp b b_tp) (pair_tp ..) = a := by - dsimp [fst, pair] - rw [toCoreAsSmallEquiv.symm_apply_eq] - subst a_tp - simp only [Grpd.comp_eq_comp, eqToHom_refl, map_id_eq, Cat.of_α, Functor.id_comp, - Equiv.apply_symm_apply] - exact sigma.fst'_pair (α := toCoreAsSmallEquiv a) (β := toCoreAsSmallEquiv b) - (B := toCoreAsSmallEquiv B) (by rw [pair_aux B a rfl b b_tp]; simp [map_id_eq]; rfl) - -lemma USig.snd_pair {Γ : Ctx} {A : Γ ⟶ U.{v}.Ty} (B : U.ext A ⟶ U.{v}.Ty) (a : Γ ⟶ U.Tm) - (a_tp : a ≫ U.tp = A) (b : Γ ⟶ U.Tm) (b_tp : b ≫ U.tp = U.sec A a a_tp ≫ B) : - USig.snd B (USig.pair B a a_tp b b_tp) (pair_tp ..) = b := by - dsimp [snd, pair] - rw [toCoreAsSmallEquiv.symm_apply_eq] - subst a_tp - simp only [Grpd.comp_eq_comp, eqToHom_refl, map_id_eq, Cat.of_α, Functor.id_comp, - Equiv.apply_symm_apply] - exact sigma.snd'_pair (α := toCoreAsSmallEquiv a) (β := toCoreAsSmallEquiv b) - (B := toCoreAsSmallEquiv B) (by rw [pair_aux B a rfl b b_tp]; simp [map_id_eq]; rfl) - -lemma USig.eta {Γ : Grpd} {A : Γ ⟶ U.Ty} (B : U.ext A ⟶ U.Ty) (s : Γ ⟶ U.Tm) - (s_tp : s ≫ U.tp = USig.Sig B) : - USig.pair B (USig.fst B s s_tp) (fst_tp ..) (USig.snd B s s_tp) (snd_tp ..) = s := by - dsimp [pair] - rw [toCoreAsSmallEquiv.symm_apply_eq] - have h := FunctorOperation.sigma.eta (toCoreAsSmallEquiv B) (toCoreAsSmallEquiv s) - (by rwa [fst_aux]) - simp only [map_id_eq, Cat.of_α, Functor.id_comp] - rw [← h] - congr 1 - simp [sigma.dependent', map_id_eq] - -def USig : PolymorphicSigma U.{v} U.{v} U.{v} where - Sig := USig.Sig - Sig_comp := USig.Sig_comp - pair := USig.pair - pair_comp := USig.pair_comp - pair_tp := USig.pair_tp - fst := USig.fst - -- fst_comp := USig.fst_comp - fst_tp := USig.fst_tp - snd := USig.snd - -- snd_comp := USig.snd_comp - snd_tp := USig.snd_tp - fst_pair := USig.fst_pair - snd_pair := USig.snd_pair - eta := USig.eta +open USig in +def USig : PolymorphicSigma U.{v} U.{v} U.{v} := + .mk' Sig Sig_comp assoc assoc_comp assoc_disp end diff --git a/HoTTLean/Groupoids/SplitClovenIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean similarity index 75% rename from HoTTLean/Groupoids/SplitClovenIsofibration.lean rename to HoTTLean/Groupoids/SplitIsofibration.lean index 2c82f4d5..b6376c0d 100644 --- a/HoTTLean/Groupoids/SplitClovenIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -68,83 +68,83 @@ open Functor.Groupoidal namespace Grpd -def SplitClovenIsofibration : MorphismProperty Grpd := - fun _ _ F => Nonempty F.SplitClovenIsofibration +def SplitIsofibration : MorphismProperty Grpd := + fun _ _ F => Nonempty F.SplitIsofibration -namespace SplitClovenIsofibration +namespace SplitIsofibration -variable {B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) +variable {B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) -def splitClovenIsofibration : F.SplitClovenIsofibration := Classical.choice hF +def splitClovenIsofibration : F.SplitIsofibration := Classical.choice hF /-- The Grothendieck construction on the classifier is isomorphic to `E`, now as objects in `Grpd`. -/ def grothendieckClassifierIso : Grpd.of (∫ hF.splitClovenIsofibration.classifier) ≅ B := - Grpd.mkIso (Functor.SplitClovenIsofibration.grothendieckClassifierIso ..) + Grpd.mkIso (Functor.SplitIsofibration.grothendieckClassifierIso ..) lemma grothendieckClassifierIso_inv_comp_forget : hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := sorry -end SplitClovenIsofibration +end SplitIsofibration -instance : SplitClovenIsofibration.IsStableUnderBaseChange.{u,u} where +instance : SplitIsofibration.IsStableUnderBaseChange.{u,u} where of_isPullback pb hG := - ⟨ Functor.SplitClovenIsofibration.ofIsPullback _ _ _ _ + ⟨ Functor.SplitIsofibration.ofIsPullback _ _ _ _ (Grpd.functorIsPullback pb) hG.splitClovenIsofibration ⟩ -instance : SplitClovenIsofibration.IsMultiplicative where - id_mem _ := ⟨ Functor.SplitClovenIsofibration.id ⟩ - comp_mem _ _ hF hG := ⟨ Functor.SplitClovenIsofibration.comp +instance : SplitIsofibration.IsMultiplicative where + id_mem _ := ⟨ Functor.SplitIsofibration.id ⟩ + comp_mem _ _ hF hG := ⟨ Functor.SplitIsofibration.comp hF.splitClovenIsofibration hG.splitClovenIsofibration ⟩ -instance : SplitClovenIsofibration.RespectsIso := +instance : SplitIsofibration.RespectsIso := MorphismProperty.respectsIso_of_isStableUnderComposition (fun X Y F hF => - ⟨ Functor.SplitClovenIsofibration.iso { + ⟨ Functor.SplitIsofibration.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] }⟩) -instance : SplitClovenIsofibration.HasObjects where +instance : SplitIsofibration.HasObjects where obj_mem F G := sorry section -open Functor.SplitClovenIsofibration +open Functor.SplitIsofibration -def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) (G : C ⟶ B) : +def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) (G : C ⟶ B) : C ⟶ Grpd.of (∫ classifier (hF.splitClovenIsofibration)) := G ≫ hF.grothendieckClassifierIso.inv -def splitClovenIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitClovenIsofibration F) - {G : C ⟶ B} (hG : SplitClovenIsofibration G) : (strictify hF G).SplitClovenIsofibration := sorry +def splitClovenIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) + {G : C ⟶ B} (hG : SplitIsofibration G) : (strictify hF G).SplitIsofibration := sorry /-- 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 : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) : Grpd := +def pushforwardLeft {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) : Grpd := Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.splitClovenIsofibration.classifier) (classifier (splitClovenIsofibration_strictify hF hG))) /-- 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 : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) : pushforwardLeft hF hG ⟶ A := +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 : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) : Over A := +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 : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) : +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 : SplitClovenIsofibration F) (σ : Over A) : +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 _) @@ -152,7 +152,7 @@ lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) ( simpa using hF.grothendieckClassifierIso_inv_comp_forget.symm ) (by simp) -lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) (σ : Over A) : +lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : Over A) : IsPullback (homOf (pre hF.splitClovenIsofibration.classifier σ.hom)) (homOf Functor.Groupoidal.forget) (homOf Functor.Groupoidal.forget) (homOf σ.hom) := by @@ -175,7 +175,7 @@ lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitClovenIsofibratio σ The two versions of the pullback are isomorphic. -/ -def pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) (σ : Over A) : +def pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : Over A) : Grpd.of (∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier) ≅ Limits.pullback σ.hom F := (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) @@ -183,8 +183,8 @@ open GroupoidModel.FunctorOperation.pi in /-- `∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier` is the pullback of `F` along `σ`, `∫ (splitClovenIsofibration_strictify hF hG).classifier` is isomorphic to `G`. So up to isomorphism this is the hom set bijection we want. -/ -def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) (σ : Over A) : +def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) (σ : Over A) : (σ ⟶ pushforward hF hG) ≃ {f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ ∫ (splitClovenIsofibration_strictify hF hG).classifier // @@ -199,8 +199,8 @@ def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration ext simp [equivFun_equivInv] -def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) (σ : Over A) : +def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} + (hG : SplitIsofibration G) (σ : Over A) : { f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ ∫ (splitClovenIsofibration_strictify hF hG).classifier // f ⋙ Functor.Groupoidal.forget = pre hF.splitClovenIsofibration.classifier σ.hom } ≃ @@ -214,8 +214,8 @@ def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration open GroupoidModel.FunctorOperation.pi in /-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ -def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) (σ : Over A) : +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) _ ≃ {f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ @@ -226,25 +226,25 @@ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) { /-- Naturality in the universal property of the pushforward. -/ -lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) +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 sorry -def pushforward_isPushforward {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) {G : C ⟶ B} - (hG : SplitClovenIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) where +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 : SplitClovenIsofibration.HasPushforwards SplitClovenIsofibration := +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 : SplitClovenIsofibration F) - (G: Over B) (hG : SplitClovenIsofibration G.hom) (G': Over A) +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) @@ -257,14 +257,14 @@ def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitClovenIsofibra -- This should follow from `Groupoidal.forget` being an splitClovenIsofibration. -- (If we manage to directly define the pushforward -- as a grothendieck construction) -theorem splitClovenIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitClovenIsofibration F) - {G : C ⟶ B} (hG : SplitClovenIsofibration G) : - SplitClovenIsofibration (pushforwardHom hF hG) := +theorem splitClovenIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) + {G : C ⟶ B} (hG : SplitIsofibration G) : + SplitIsofibration (pushforwardHom hF hG) := sorry -- FIXME. For some reason needed in the proof --- `SplitClovenIsofibration.IsStableUnderPushforward SplitClovenIsofibration` -instance SplitClovenIsofibration.RespectsIso : SplitClovenIsofibration.RespectsIso := inferInstance +-- `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 @@ -273,22 +273,22 @@ instance SplitClovenIsofibration.RespectsIso : SplitClovenIsofibration.RespectsI `(F.op ⋙ yoneda.obj X).IsRepresentable` and `(F.op ⋙ yoneda.obj Y).IsRepresentable` implies `X ≅ Y`. - 2. SplitClovenIsofibrations are stable under isomorphism (this is in mathlib, for any `rlp`) + 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 splitClovenIsofibration `splitClovenIsofibration_pushforward` -/ -instance : SplitClovenIsofibration.IsStableUnderPushforward SplitClovenIsofibration where +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 : SplitClovenIsofibration (pushforwardHom (F.snd) (G.snd)) := by + have i1 : SplitIsofibration (pushforwardHom (F.snd) (G.snd)) := by apply splitClovenIsofibration_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 (SplitClovenIsofibration.RespectsIso).precomp + apply (SplitIsofibration.RespectsIso).precomp assumption diff --git a/HoTTLean/Groupoids/StructuredModel.lean b/HoTTLean/Groupoids/StructuredModel.lean index cd1904cf..915deec6 100644 --- a/HoTTLean/Groupoids/StructuredModel.lean +++ b/HoTTLean/Groupoids/StructuredModel.lean @@ -1,4 +1,4 @@ -import HoTTLean.Groupoids.SplitClovenIsofibration +import HoTTLean.Groupoids.SplitIsofibration /-! Here we construct universes for the groupoid natural model. @@ -18,7 +18,7 @@ open U The π-clan we use is the set of groupoid isofibrations. -/ @[simps!] -def StructuredU : StructuredUniverse Grpd.SplitClovenIsofibration where +def StructuredU : StructuredUniverse Grpd.SplitIsofibration where __ := U morphismProperty := sorry @@ -26,7 +26,7 @@ namespace U open MonoidalCategory -def liftSeqObjs (i : Nat) (h : i < 4) : StructuredUniverse Grpd.SplitClovenIsofibration.{5} := +def liftSeqObjs (i : Nat) (h : i < 4) : StructuredUniverse Grpd.SplitIsofibration.{5} := match i with | 0 => StructuredU.{0,4} | 1 => StructuredU.{1,4} @@ -55,7 +55,7 @@ def liftSeqHomSucc' (i : Nat) (h : i < 3) : The groupoid natural model with three nested representable universes within the ambient natural model. -/ -def liftSeq : UHomSeq Grpd.SplitClovenIsofibration.{5} where +def liftSeq : UHomSeq Grpd.SplitIsofibration.{5} where length := 3 objs := liftSeqObjs homSucc' := liftSeqHomSucc' diff --git a/HoTTLean/Groupoids/UnstructuredModel.lean b/HoTTLean/Groupoids/UnstructuredModel.lean index 23b7ce87..4e1fd38b 100644 --- a/HoTTLean/Groupoids/UnstructuredModel.lean +++ b/HoTTLean/Groupoids/UnstructuredModel.lean @@ -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] From b04c223ba5b62a5940b83d86e8e12d514d962e54 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 16 Oct 2025 18:59:35 -0400 Subject: [PATCH 46/59] feat: comp.liftObj_comp --- .../CategoryTheory/SplitIsofibration.lean | 62 ++++++++++++++++--- 1 file changed, 53 insertions(+), 9 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 5da4cc76..45efb90d 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -54,7 +54,7 @@ instance {X : Γ} : IsGroupoid (F.Fiber X) where instance {X : Γ} : Groupoid (F.Fiber X) := Groupoid.ofIsGroupoid end Fiber - +section variable {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] structure ClovenIsofibration (F : C ⥤ D) where @@ -67,7 +67,6 @@ structure ClovenIsofibration (F : C ⥤ D) where - section variable {F : C ⥤ D} (I : ClovenIsofibration F) @@ -77,6 +76,10 @@ variable {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 liftIso_IsIso {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 ClovenIsofibration.obj_liftObj {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : F.obj (I.liftObj f hX') = Y := @@ -126,7 +129,7 @@ structure SplitIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Categ -- lemma liftObj_codomain (F : C ⥤ D) {X Y Z: D} (f: X ⟶ Y) [IsIso f] {X': C} (hX': F.obj X' = X) (e: Y = Z): -- I.liftObj f hX' = - +end namespace SplitIsofibration open ClovenIsofibration @@ -136,15 +139,16 @@ lemma liftObj_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v (F : C ⥤ D) (I : SplitIsofibration F) {X Y : D} (h : X = Y) {X' : C} (hX' : F.obj X' = X) : I.liftObj (eqToHom h) hX' = X' := by subst h - simp [liftObj_id] + simp [SplitIsofibration.liftObj_id] @[simp] lemma liftIso_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] (F : C ⥤ D) (I : SplitIsofibration F) {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 [liftIso_id] + simp [SplitIsofibration.liftIso_id] +section variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} (I : SplitIsofibration F) @@ -516,6 +520,8 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E := -- inv_hom_id := sorry +end + def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : SplitIsofibration F.hom where liftObj {b0 b1} f hf x hF := F.inv.obj b1 @@ -544,14 +550,19 @@ variables {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F def comp.liftObj {X Y: C} (f: X ⟶ Y) [i: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) - have i0 : IsIso f1 := sorry + --have i0 : IsIso f1 := sorry IF.liftObj (X' := X') f1 rfl + +lemma comp.obj_liftObj {X Y: C} (f: X ⟶ Y) [i: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) [i: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) - have i0 : IsIso f1 := sorry - IF.liftIso (X' := X') f1 rfl + --have i0 : IsIso f1 := sorry + IF.liftIso (X' := X') f1 rfl def comp.isHomLift {X Y: C} (f: X ⟶ Y) [i:IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X): (F ⋙ G).IsHomLift f (comp.liftIso IF IG f hX') := by @@ -608,6 +619,23 @@ lemma comp.liftIso_id {X : C} {X' : A} (hX' : (F ⋙ G).obj X' = X) : -- sorry +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) (Y' : A) + (hY' : comp.liftObj IF IG f hX' = Y'): + 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[comp.liftObj] + simp[liftIso_comp] + simp[SplitIsofibration.liftObj_comp] + congr! + simp[ClovenIsofibration.obj_liftObj] + + +-- lemma comp.liftObj_liftIso {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'): +-- IF.liftObj (IG.liftIso f hX') rfl = sorry := sorry /-- `IsMultiplicative` 1/2 -/ def comp : @@ -622,7 +650,23 @@ def comp : intro X X' hX' apply comp.liftIso_id liftObj_comp := by - sorry + intro X Y Z f i1 g i2 X' hX' Y' hY' + simp[comp.liftObj,SplitIsofibration.liftIso_comp] + have a := (IG.liftIso f hX') + have p1 : G.obj (IG.liftObj f hX') = Y := by simp[] + have p2 : IG.liftObj g p1 = IG.liftObj (f ≫ g) hX' := by + simp[SplitIsofibration.liftObj_comp] + have e1 := @SplitIsofibration.liftObj_comp + (f:= IG.liftIso f hX') (g:= IG.liftIso g p1 ≫ eqToHom p2) _ _ _ _ F IF _ _ _ _ _ X' rfl + (IF.liftObj (IG.liftIso f hX') rfl) rfl + rw[e1] + rw[ SplitIsofibration.liftObj_comp,liftObj_eqToHom] + congr! + · subst hY' + simp[comp.liftObj] + subst hY' + simp[comp.liftObj] + liftIso_comp := sorry liftIso_IsIso := sorry From 6997ede6cbd621577d28d9567850efd57b988820 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 16 Oct 2025 20:50:08 -0400 Subject: [PATCH 47/59] golf --- .../CategoryTheory/SplitIsofibration.lean | 20 +++---------------- 1 file changed, 3 insertions(+), 17 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 45efb90d..da0fab64 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -620,8 +620,7 @@ lemma comp.liftIso_id {X : C} {X' : A} (hX' : (F ⋙ G).obj X' = X) : -- sorry 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) (Y' : A) - (hY' : comp.liftObj IF IG f hX' = Y'): + (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 @@ -651,21 +650,8 @@ def comp : apply comp.liftIso_id liftObj_comp := by intro X Y Z f i1 g i2 X' hX' Y' hY' - simp[comp.liftObj,SplitIsofibration.liftIso_comp] - have a := (IG.liftIso f hX') - have p1 : G.obj (IG.liftObj f hX') = Y := by simp[] - have p2 : IG.liftObj g p1 = IG.liftObj (f ≫ g) hX' := by - simp[SplitIsofibration.liftObj_comp] - have e1 := @SplitIsofibration.liftObj_comp - (f:= IG.liftIso f hX') (g:= IG.liftIso g p1 ≫ eqToHom p2) _ _ _ _ F IF _ _ _ _ _ X' rfl - (IF.liftObj (IG.liftIso f hX') rfl) rfl - rw[e1] - rw[ SplitIsofibration.liftObj_comp,liftObj_eqToHom] - congr! - · subst hY' - simp[comp.liftObj] - subst hY' - simp[comp.liftObj] + simp[comp.liftObj_comp] + congr liftIso_comp := sorry liftIso_IsIso := sorry From ebbcbf2403c995136f39fdb7bb16d6bd4398d424 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sat, 18 Oct 2025 22:33:14 -0400 Subject: [PATCH 48/59] comp, to be golfed --- .../CategoryTheory/SplitIsofibration.lean | 84 +++++++++++-------- 1 file changed, 50 insertions(+), 34 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index da0fab64..ae891723 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -581,24 +581,6 @@ def comp.isHomLift {X Y: C} (f: X ⟶ Y) [i:IsIso f] {X': A} (hX': (F ⋙ G).obj 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] --- rw![liftIso_id] --- --have i: IsIso (eqToHom sorry ≫ 𝟙 _) := sorry --- have h1 : eqToHom (Eq.symm (IG.liftObj_id hX')) = eqToHom (Eq.symm (IG.liftObj_id hX')) ≫ 𝟙 _ := sorry --- rw![h1] --- rw [liftObj_comp] --- have e0 : IG.liftObj (𝟙 X) hX' = F.obj X' := sorry --- rw![e0] --- · --- sorry --- · sorry --- --convert_to @liftObj _ _ _ _ _ _ _ IF _ _ (𝟙 (F.obj X')) _ = _ --- · sorry --- --apply liftObj_id - --- -- have h : IF.liftObj (eqToHom (Eq.symm (IG.liftObj_id hX'))) rfl = X':= sorry --- -- have h: IF.liftObj (eqToHom (Eq.symm (IG.liftObj_id hX')) ≫ 𝟙 (F.obj X')) (by sorry) = X' := sorry --- -- simp[eqToHom] --- -- sorry lemma comp.liftIso_id {X : C} {X' : A} (hX' : (F ⋙ G).obj X' = X) : @@ -608,28 +590,56 @@ lemma comp.liftIso_id {X : C} {X' : A} (hX' : (F ⋙ G).obj X' = X) : simp [← heq_eq_eq] apply HEq.trans (eqToHom_heq_id_dom _ _ _) (eqToHom_heq_id_dom _ _ _).symm - -- have e : (IG.liftIso (𝟙 X) hX') = eqToHom (by simp[SplitIsofibration.liftObj_id]) := by - -- apply SplitIsofibration.liftIso_id - - -- --let e:= SplitIsofibration.liftIso_id (X' := F.obj X') - -- --rw! (castMode := .all)[liftIso_eqToHom] - -- rw! (castMode := .all)[e] - -- rw[liftIso_eqToHom] - -- rw!(castMode := .all)[liftObj_eqToHom] - - -- sorry 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[comp.liftObj] - simp[liftIso_comp] - simp[SplitIsofibration.liftObj_comp] + simp only [liftObj, liftIso_comp, eqToHom_refl, Category.id_comp, SplitIsofibration.liftObj_comp, + liftObj_eqToHom] congr! simp[ClovenIsofibration.obj_liftObj] +/-(by simp[liftObj,SplitIsofibration.liftIso_comp,SplitIsofibration.liftObj_comp]; + congr!; )-/ + +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] + + +lemma comp.liftIso_comp_aux1 {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'): + liftObj IF IG g (X' := Y') (comp.liftIso_comp_aux IF IG f g hX' Y' hY') = + liftObj IF IG (f ≫ g) hX' := + sorry + +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 + symm; subst hY'; simp[comp.liftObj_comp]) := + by + simp[comp.liftIso,comp.liftObj] + simp at hX' + have e:= @SplitIsofibration.liftIso_comp + (f:= f) (g:= g) _ _ _ _ G IG X Y Z _ _ (F.obj X') hX' (IG.liftObj f hX') rfl + rw![e] + simp[eqToHom_refl] + rw![Category.id_comp] + simp[SplitIsofibration.liftIso_comp] + congr 1 + simp[← heq_eq_eq] + congr! + · subst hY' + simp[liftObj] --do not know why it works, but it did + subst hY' + simp[liftObj] -- lemma comp.liftObj_liftIso {X Y Z : C} (f : X ⟶ Y) [IsIso f] (g : Y ⟶ Z) [ IsIso g] {X' : A} -- (hX' : (F ⋙ G).obj X' = X) (Y' : A) @@ -650,11 +660,17 @@ def comp : apply comp.liftIso_id liftObj_comp := by intro X Y Z f i1 g i2 X' hX' Y' hY' - simp[comp.liftObj_comp] + simp only [comp.liftObj_comp] congr + liftIso_comp := by + intro X Y Z f i1 g i2 X' hX' Y' hY' + simp only [comp.liftIso_comp] + congr! + liftIso_IsIso := by + intro X Y f i1 X' hX' + simp[comp.liftIso] + apply liftIso_IsIso - liftIso_comp := sorry - liftIso_IsIso := sorry /-- `IsStableUnderBaseChange` -/ def ofIsPullback {A B A' B' : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} A'] From 64a45f5f0370a4aea5b9859b092bbe77474f810d Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sat, 18 Oct 2025 22:48:59 -0400 Subject: [PATCH 49/59] comp, golfed --- .../CategoryTheory/SplitIsofibration.lean | 179 ++++-------------- 1 file changed, 38 insertions(+), 141 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index ae891723..b9c138cd 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -70,9 +70,6 @@ structure ClovenIsofibration (F : C ⥤ D) where section variable {F : C ⥤ D} (I : ClovenIsofibration F) --- instance liftIso_IsIso (F : C ⥤ D) {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : --- IsIso (I.liftIso f hX') := sorry - 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' @@ -126,9 +123,6 @@ structure SplitIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Categ eqToHom (liftObj_comp f g hX' Y' hY').symm --- lemma liftObj_codomain (F : C ⥤ D) {X Y Z: D} (f: X ⟶ Y) [IsIso f] {X': C} (hX': F.obj X' = X) (e: Y = Z): --- I.liftObj f hX' = - end namespace SplitIsofibration @@ -319,35 +313,14 @@ def grothendieckClassifierIso.hom.map' {p1 p2: ∫ I.classifier} (h: p1 ⟶ p2) 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] - --convert_to - -- rw! (castMode := .all) [Grpd.id_eq_id,hom.map_aux,liftObj_id] + 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] - --rfl - --convert_to _ ≫ _ ≫ Fiber.fiberInclusion.map (Hom.fiber (𝟙 X)) = _ - --- simp [map', liftIsoComp] --- simp [map',liftIsoComp,classifier] --- congr 1 --- convert_to _ ≫ _ ≫ _ ≫ _ ≫ _ = _ --- simp[← Category.assoc] --- congr 1 --- simp[classifier.map.map] --- simp[← Category.assoc] --- congr --- simp[Category.assoc] --- simp[Hom.fiber] --- congr - --simp[Category.assoc] - --- sorry - --convert_to _ ≫ eqToHom _ ≫ Fiber.fiberInclusion.map _ ≫ _ = _ + 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) : @@ -364,17 +337,6 @@ def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E := (by intro X; ext;simp[hom.hom,liftIso_id]) (by intro X Y Z f g; ext; simp[hom.hom,liftIso_comp]) --- lemma grothendieckClassifierIso.hom_comp_self : hom I ⋙ F = Groupoidal.forget := by - --- #check functorFrom_ext --- sorry - --- def grothendieckClassifierIso.hom : ∫ I.classifier ⥤ E where --- obj p := p.fiber.1 --- map := grothendieckClassifierIso.hom.map I --- map_id X := by apply grothendieckClassifierIso.hom.map_id .. --- map_comp := sorry--grothendieckClassifierIso.hom.map_comp I - def grothendieckClassifierIso.inv.fibMap {X Y}(f : X ⟶ Y) : ((F ⋙ I.classifier).map f).obj ⟨X,rfl⟩ ⟶ ⟨Y, rfl⟩ := by -- simp[classifier,classifier.map.obj] @@ -403,15 +365,6 @@ lemma grothendieckClassifierIso.inv.fibMap_comp {x y z : E} (f : x ⟶ y) (g : y simp[liftIso_comp] simp[eqToHom_map,classifier,classifier.map.map] --- def grothendieckClassifierIso.inv : E ⥤ ∫ I.classifier := --- Groupoidal.functorTo F (fun x => ⟨x, rfl⟩) --- (fun f => inv.fibMap I f) --- (fun x => inv.fibMap_id I x) --- (fun f g => inv.fibMap_comp I f g) - --- lemma grothendieckClassifierIso.inv_comp_forget : grothendieckClassifierIso.inv I ⋙ - -- Groupoidal.forget = F := - -- Groupoidal.functorTo_forget lemma ι_classifier_comp_forget {x} : ι I.classifier x ⋙ Groupoidal.forget = Fiber.fiberInclusion ⋙ F := by @@ -483,42 +436,6 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E := rw [I.liftObj_comp _ _ _ _ rfl, I.liftObj_comp _ _ _ _ rfl] simp) --- def grothendieckClassifierIso' : ∫ I.classifier ≅≅ E where --- hom := grothendieckClassifierIso.hom .. --- inv := grothendieckClassifierIso.inv .. --- hom_inv_id := by --- fapply Functor.Groupoidal.FunctorTo.hext --- · simp [Functor.assoc, grothendieckClassifierIso.inv_comp_forget,grothendieckClassifierIso.hom_comp_self] --- · sorry --- · sorry --- -- fapply ext --- -- · intro p --- -- simp[grothendieckClassifierIso.hom,grothendieckClassifierIso.inv] --- -- fapply CategoryTheory.Functor.Groupoidal.ext --- -- · rw[functorTo_obj_base] --- -- · apply grothendieckClassifierIso.hom.map_aux2 --- -- · intro x y z f g --- -- simp[grothendieckClassifierIso.inv.fibMap,classifier,classifier.map.map] --- -- rw![Functor.map_comp] --- -- simp[Fiber.homMk,liftIso_comp] --- -- ext --- -- simp[eqToHom_map] --- -- congr --- -- · rw![functorTo_obj_fiber] --- -- · simp --- -- simp[grothendieckClassifierIso.inv.fibMap,classifier, classifier.map.obj] --- -- rw![grothendieckClassifierIso.hom.map_aux2] --- -- rw! (castMode := .all) [functorTo_obj_base] --- -- --F.obj (I.liftObj (eqToHom ⋯) ⋯) = p.base --- -- --apply Fiber.hom_ext --- -- --fapply CategoryTheory.Functor.Groupoidal.hext --- -- --simp[eqToHom_map] --- -- sorry - --- -- · sorry - - --- inv_hom_id := sorry end @@ -536,33 +453,32 @@ def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : liftIso_id := by simp liftObj_comp := by simp liftIso_comp := by simp - liftIso_IsIso := sorry + liftIso_IsIso := by + intro X Y f i X' hX' + apply IsIso.comp_isIso def id {A : Type u} [Category.{v} A] : SplitIsofibration (𝟭 A) := iso (Functor.Iso.refl _) section -variables {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} - (IF : SplitIsofibration F) {G : B ⥤ C} (IG : SplitIsofibration G) +variable {A B C : Type u} [Category.{v} A] [Category.{v} B] [Category.{v} C] {F : A ⥤ B} + (IF : SplitIsofibration F) {G : B ⥤ C} (IG : SplitIsofibration G) def comp.liftObj {X Y: C} (f: X ⟶ Y) [i: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) - --have i0 : IsIso f1 := sorry - IF.liftObj (X' := X') f1 rfl + := 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) [i:IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X): +lemma comp.obj_liftObj {X Y: C} (f: X ⟶ Y) [i: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) [i: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) - --have i0 : IsIso f1 := sorry - IF.liftIso (X' := X') f1 rfl +def comp.liftIso {X Y: C} (f: X ⟶ Y) [i: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 def comp.isHomLift {X Y: C} (f: X ⟶ Y) [i:IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X): (F ⋙ G).IsHomLift f (comp.liftIso IF IG f hX') := by @@ -592,59 +508,40 @@ lemma comp.liftIso_id {X : C} {X' : A} (hX' : (F ⋙ G).obj X' = X) : 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, SplitIsofibration.liftObj_comp, - liftObj_eqToHom] - congr! - simp[ClovenIsofibration.obj_liftObj] + (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, SplitIsofibration.liftObj_comp, + liftObj_eqToHom] + congr! + simp[ClovenIsofibration.obj_liftObj] -/-(by simp[liftObj,SplitIsofibration.liftIso_comp,SplitIsofibration.liftObj_comp]; - congr!; )-/ 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] - + (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] -lemma comp.liftIso_comp_aux1 {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'): - liftObj IF IG g (X' := Y') (comp.liftIso_comp_aux IF IG f g hX' Y' hY') = - liftObj IF IG (f ≫ g) hX' := - sorry 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 - symm; subst hY'; simp[comp.liftObj_comp]) := - by - simp[comp.liftIso,comp.liftObj] - simp at hX' - have e:= @SplitIsofibration.liftIso_comp - (f:= f) (g:= g) _ _ _ _ G IG X Y Z _ _ (F.obj X') hX' (IG.liftObj f hX') rfl - rw![e] - simp[eqToHom_refl] - rw![Category.id_comp] - simp[SplitIsofibration.liftIso_comp] + (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 + simp only [liftObj, liftIso] + have e:= @SplitIsofibration.liftIso_comp (f:= f) (g:= g) _ _ _ _ G IG X Y Z _ _ (F.obj X') hX' (IG.liftObj f hX') rfl + rw![e,eqToHom_refl,Category.id_comp] + simp only [SplitIsofibration.liftIso_comp, eqToHom_refl, liftIso_eqToHom, eqToHom_trans, + Category.id_comp, Category.assoc] congr 1 - simp[← heq_eq_eq] + simp only [← heq_eq_eq, heq_eqToHom_comp_iff, heq_comp_eqToHom_iff, comp_eqToHom_heq_iff] congr! · subst hY' simp[liftObj] --do not know why it works, but it did subst hY' simp[liftObj] --- lemma comp.liftObj_liftIso {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'): --- IF.liftObj (IG.liftIso f hX') rfl = sorry := sorry /-- `IsMultiplicative` 1/2 -/ def comp : From f2f5fc56a81cdc8905366fb7c957eced03604519 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Tue, 21 Oct 2025 13:54:20 -0400 Subject: [PATCH 50/59] feat: forget SplitIso --- .../Bicategory/Grothendieck.lean | 48 ++++ .../CategoryTheory/SplitIsofibration.lean | 227 ++++++++++++++++-- HoTTLean/Grothendieck/Groupoidal/Basic.lean | 46 ++++ 3 files changed, 297 insertions(+), 24 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index ecacfe96..97a6ba6a 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean @@ -579,6 +579,13 @@ If `F : C ⥤ Cat` is a functor and `t : c ⟶ d` is a morphism in `C`, then `tr def transport (x : ∫ F) {c : C} (t : x.base ⟶ c) : ∫ F := mk c ((F.map t).obj x.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 + + + @[simp] def transport_base (x : ∫ F) {c : C} (t : x.base ⟶ c) : (transport x t).base = c := rfl @@ -606,6 +613,47 @@ 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] + simp + +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 + fapply 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[← heq_eq_eq,← Category.assoc] + simp only [toTransport, transport_base, transport_fiber] + fapply Grothendieck.Hom.hext' + · rfl + · rfl + · simp[transport_comp] + · simp + simp + symm + apply eqToHom_heq_id_dom + /-- Construct an isomorphism in a Grothendieck construction from isomorphisms in its base and fiber. -/ diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index b9c138cd..373b5797 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -2,7 +2,7 @@ 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 universe w v u v₁ u₁ v₂ u₂ v₃ u₃ noncomputable section @@ -169,21 +169,6 @@ def classifier.map.map {X Y} (f: X ⟶ Y) {a b : F.Fiber X} (m : a ⟶ b) : simp Fiber.homMk F _ i --- 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 ≫ m.1 ≫ i2 --- have e :𝟙 Y = eqToHom (by simp[obj_liftObj]) ≫ --- F.map (CategoryTheory.inv i1 ≫ m.1 ≫ i2) ≫ eqToHom (by simp[obj_liftObj]) --- := by --- simp[i1, i2, classifier.fac', 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 @@ -261,14 +246,6 @@ lemma grothendieckClassifierIso.hom.map_aux simp[classifier,classifier.map.obj] --- lemma grothendieckClassifierIso.hom.hom.map_aux --- {X Y: Γ} (f: X ⟶ Y) (a: I.classifier.obj X) (b: I.classifier.obj Y) --- (h: (I.classifier.map f).obj a ⟶ b ) --- : (I.classifier.map f).obj a = sorry := by - --- simp[classifier,classifier.map.obj] --- sorry - /- @@ -457,6 +434,208 @@ 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 + +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) + + +def 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) := by infer_instance + -- let tinv := (asIso t).inv + -- let tinv': (x.transport t).base ⟶ x.base := (asIso t).inv + -- let f1 := Groupoidal.toTransport (x.transport t) tinv' + -- exact ⟨f1 ≫ eqToHom + -- (by simp[tinv']; + -- fapply Groupoidal.ext + -- · simp + -- · simp + -- simp[← Functor.comp_obj,← Grpd.comp_eq_comp] + + -- --sorry --previous proof below + -- -- simp only [eqToHom_refl, map_id, Grpd.id_eq_id, Groupoidal.transport_fiber, + -- -- id_obj] + -- -- simp only[← Functor.comp_obj] + -- -- --simp[← Grothendieck.map_comp_eq] + -- -- simp only [← Functor.map_comp,← Grpd.comp_eq_comp] + -- -- simp + -- ) , + -- sorry⟩ + +def forget.liftIso_IsIso {X Y: C} (f : X ⟶ Y) + [IsIso f] {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X) : + IsIso (forget.liftIso f hX') + := by + simp[liftIso] + apply toTransport_IsIso + + +/- +lemma transport_id {X' : F.Groupoidal}: + X'.transport (𝟙 X'.base) = X' := by + fapply Groupoidal.ext + · simp[Groupoidal.transport,Grothendieck.transport,Groupoidal.base] + simp[Groupoidal.fiber,Grpd.forgetToCat,Functor.map_id] + simp[Groupoidal.transport,Grothendieck.transport,Grpd.forgetToCat] + have e: (F.map (𝟙 X'.base)) = Functor.id _ := by simp + simp[e] + + +lemma transport_eqToHom {X: C} {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X): + X'.transport (eqToHom hX') = X' := by + subst hX' + simp[transport_id] + -- fapply Groupoidal.ext + -- · simp[transport_id] + -- -- simp[Groupoidal.base] + -- simp[Groupoidal.fiber,Grpd.forgetToCat,Functor.map_id] + -- have e: (F.map (𝟙 X'.base)) = Functor.id _ := by simp + --simp[e] + + should be in groupoidal file +-/ + +def forget.liftObj_id {X: C} {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X) : + forget.liftObj (𝟙 X) hX' = X' := by + simp[liftObj] + simp[Groupoidal.transport_eqToHom] + --simp[Groupoidal.transport,Grothendieck.transport] + +/- +lemma toTransport_eqToHom {X: C} {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X): + Groupoidal.toTransport X' (eqToHom hX') = eqToHom (by subst hX'; sorry) := by + apply Groupoidal.toTransport_eqToHom +-/ + + -- subst hX' + -- simp[Groupoidal.toTransport,Grothendieck.toTransport] + -- fapply Groupoidal.Hom.ext + -- · simp[Groupoidal.Hom.base,Groupoidal.base] + -- rw![Grothendieck.Hom.base] + -- sorry + -- sorry + +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 + simp[liftIso] + rw! (castMode :=.all)[Category.comp_id] + simp[Groupoidal.toTransport_eqToHom] + simp[← heq_eq_eq] + congr! + + + --conv => rhs ; rw[← toTransport_eqToHom] + + --rw[← toTransport_eqToHom] + + + /-simp only [eqToHom_refl, map_id, Grpd.id_eq_id, Groupoidal.transport_fiber, + -- -- id_obj] + -- -- simp only[← Functor.comp_obj] + -- -- --simp[← Grothendieck.map_comp_eq] + -- -- simp only [← Functor.map_comp,← Grpd.comp_eq_comp] + -- -- simp + -- ) ,-/ + +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') + (h': Y'.base = Y := by simp[]): + forget.liftObj (f ≫ g) hX' = forget.liftObj g h' := 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') + (h': Y'.base = Y := by simp[]) + (e : liftObj g h' = liftObj (f ≫ g) hX' := by apply forget.liftObj_comp): + forget.liftIso (f ≫ g) hX' = forget.liftIso f hX' ≫ eqToHom hY' ≫ + forget.liftIso g h' ≫ eqToHom e := by + simp only [liftIso] + subst hX' hY' + simp + simp[Groupoidal.toTransport_comp] + simp[Groupoidal.toTransport_id] + congr 2 + simp[← heq_eq_eq,← Category.assoc,liftObj] + congr 1 + rw[Groupoidal.transport_congr ((X'.transport (𝟙 X'.base))) X' (by rw[Groupoidal.transport_id]) + f f (by simp)] + + rw[Groupoidal.transport_congr (X'.transport (𝟙 X'.base ≫ f)) (X'.transport f) _ + ((𝟙 (X'.transport (𝟙 X'.base ≫ f)).base)) (eqToHom (by simp))] + · simp[Groupoidal.transport_id] + · simp + · simp + + + -- simp[Category.assoc] + -- simp[Groupoidal.toTransport_eqToHom] + + -- simp + -- rw!(castMode :=.all)[Groupoidal.transport_id] + -- rw!(castMode :=.all)[Groupoidal.transport_eqToHom] + -- rw!(castMode :=.all)[← Category.assoc] + -- simp[Groupoidal.toTransport_comp] + -- congr 1 + -- congr 1 + -- --simp[Category.assoc] + -- simp[← heq_eq_eq] + -- simp[← Category.assoc] + -- rw!(castMode :=.all)[Groupoidal.transport_eqToHom] + + --simp[heq_comp_eqToHom_iff] this one is autosimp + --conv in (eqToHom sorry ≫ f ≫ g) => simp[← CategoryStruct.assoc] + + + +def forget : + SplitIsofibration (Groupoidal.forget (F := F)) where + liftObj f := forget.liftObj f + liftIso f := forget.liftIso f + isHomLift f := forget.isHomLift f + liftIso_IsIso f := forget.liftIso_IsIso f + liftObj_id f := forget.liftObj_id f + liftIso_id f := forget.liftIso_id f + liftObj_comp {X Y Z} f _ g _ := by + intro X' hX' Y' hY' + apply forget.liftObj_comp + assumption + liftIso_comp := by + intro X Y Z f i1 g i2 X' hX' Y' hY' + apply forget.liftIso_comp + + + +end + + + def id {A : Type u} [Category.{v} A] : SplitIsofibration (𝟭 A) := iso (Functor.Iso.refl _) diff --git a/HoTTLean/Grothendieck/Groupoidal/Basic.lean b/HoTTLean/Grothendieck/Groupoidal/Basic.lean index d2ea16ea..df256ca9 100644 --- a/HoTTLean/Grothendieck/Groupoidal/Basic.lean +++ b/HoTTLean/Grothendieck/Groupoidal/Basic.lean @@ -220,6 +220,52 @@ 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': Groupoidal.forget.obj X' = X): + X'.transport (eqToHom hX') = X' := by + apply Grothendieck.transport_eqToHom + + +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 + + +--do not even need to compose with eqToHom (x.transport t).base = c, c:= d +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 transporting (x : ∫(F)) : C ⥤ ∫ F where +-- obj := sorry +-- map := sorry +-- map_id := sorry +-- map_comp := sorry + def isoMk {X Y : ∫(F)} (f : X ⟶ Y) : X ≅ Y := by fapply Grothendieck.isoMk · exact (Groupoid.isoEquivHom _ _).2 f.base From bf0bbdd94c1131e7035c1c3f756509377c5bf2e6 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Wed, 22 Oct 2025 23:28:07 -0400 Subject: [PATCH 51/59] progress on pb --- .../Bicategory/Grothendieck.lean | 1 + .../CategoryTheory/Functor/IsPullback.lean | 50 +++++++++++ .../CategoryTheory/SplitIsofibration.lean | 82 ++++++++++++++++--- .../Grothendieck/Groupoidal/IsPullback.lean | 22 +++++ 4 files changed, 142 insertions(+), 13 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean index 97a6ba6a..cf050735 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Bicategory/Grothendieck.lean @@ -1466,6 +1466,7 @@ def mapWhiskerRightAsSmallFunctor (α : F ⟶ G) : end AsSmall + end Grothendieck end Functor diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean index 18c2b15f..21e2e090 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean @@ -467,6 +467,54 @@ def ofIso' : IsPullback north' west' east' south' := end + +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' where + hom := by + have i1 := h.toChosen + have i2 := h.fromChosen + sorry + inv := sorry + hom_inv_id := sorry + inv_hom_id := 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 + namespace Paste variable {Algeria Libya Egypt Niger Chad Sudan : Type*} [Category Algeria] [Category Libya] [Category Egypt] [Category Niger] [Category Chad] [Category Sudan] @@ -684,6 +732,7 @@ def universal : (lift : C ⥤ Algeria) ×' end ofRight' + /-- Pullback pasting <=, where the map `Algeria ⥤ Libya` is generated by the universal property of the right square @@ -858,6 +907,7 @@ noncomputable def functorIsPullback {Libya Egypt Chad Sudan : Type v} [Groupoid. end Grpd + /-- The following square is a pullback diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 373b5797..293085be 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -748,20 +748,15 @@ def comp : apply liftIso_IsIso -/-- `IsStableUnderBaseChange` -/ -def ofIsPullback {A B A' B' : 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 - liftIso_comp := sorry - liftIso_IsIso := sorry +instance isoComp_SplitIsofibration {A A' B : Type u} [Category.{v} A] [Category.{v} A'] + [Category.{v} B] + (i : A' ≅≅ A) (F: A ⥤ B) (IF: SplitIsofibration F): SplitIsofibration (i.hom ⋙ F) := sorry +instance iso_SplitIsofibration {A A' B : Type u} [Category.{v} A] [Category.{v} A'] + [Category.{v} B] + (i : A' ≅≅ A) (F: A ⥤ B) (IF: SplitIsofibration F): SplitIsofibration (i.hom ⋙ F) := sorry + +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) : @@ -774,6 +769,67 @@ def ofIsPullback {A B A' B' : Type u} [Category.{v} A] [Category.{v} B] [Categor -- liftObj_comp := sorry -- liftIsoComp := sorry +section +/-- `IsStableUnderBaseChange` -/ + +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 : SplitIsofibration F) : + SplitIsofibration F' := by + --have c:= SplitIsofibration.classifier IF + --have p : Functor.Groupoidal IF.classifier ≅≅ A := sorry + have Ichar : SplitIsofibration (Groupoidal.forget (F := IF.classifier)) := by + apply Functor.SplitIsofibration.forget + have Ichar' : SplitIsofibration (Groupoidal.forget (F := bot ⋙ IF.classifier)) := by + apply Functor.SplitIsofibration.forget + let i0 : Functor.Groupoidal IF.classifier ≅≅ A := + Functor.SplitIsofibration.grothendieckClassifierIso .. + have e0 : i0.hom ⋙ F = Groupoidal.forget := by + simp[i0] + + sorry + -- have p1 : Functor.IsPullback (Libya := A') (Egypt := PGrpd) + -- (top ⋙ i0.hom ⋙ Groupoidal.toPGrpd IF.classifier) + -- F' PGrpd.forgetToGrpd (bot ⋙ IF.classifier) + -- := sorry + -- have p2 : Functor.IsPullback + -- (Groupoidal.toPGrpd (bot ⋙ IF.classifier)) + -- Groupoidal.forget PGrpd.forgetToGrpd (bot ⋙ IF.classifier) + -- := sorry + + have q2 : Functor.IsPullback (Libya := A') (Egypt := A) + top F' F bot + := isPullback + have gpb : Functor.IsPullback (Groupoidal.pre IF.classifier bot) + Groupoidal.forget Groupoidal.forget bot := by + apply Groupoidal.compGrothendieck.isPullback + let d := IsPullback.IsPullback.botDegenerate e0.symm + have paste := Functor.IsPullback.Paste.horiz sorry sorry d gpb + simp[Functor.id_comp] at paste + have q1 : Functor.IsPullback + (Groupoidal.pre IF.classifier bot ⋙ i0.hom) + (Groupoidal.forget (F := (bot ⋙ IF.classifier))) F bot + := paste + let j : A' ≅≅ Functor.Groupoidal (F := bot ⋙ IF.classifier) := + Functor.IsPullback.isoIsPullback q2 q1 + have e: F' = j.hom ⋙ (Groupoidal.forget (F := bot ⋙ IF.classifier)) := by + symm + have e1 := IsPullback.isoIsPullback.homCompRight' q2 q1 (hom := j.hom) (by simp[j]) + exact e1 + -- let i : A' ≅≅ Functor.Groupoidal (F := bot ⋙ IF.classifier) := + -- Functor.IsPullback.isoIsPullback p1 p2 + -- have eq: F' = i.hom ⋙ (Groupoidal.forget (F := bot ⋙ IF.classifier)) := by + -- symm + -- --simp[i] + -- have e1 := IsPullback.isoIsPullback.homCompLeft' p1 p2 (hom := i.hom) (by simp[i]) + + -- sorry + simp[e] + apply iso_SplitIsofibration j (Groupoidal.forget (F := bot ⋙ IF.classifier)) + exact Ichar' + + +end #exit namespace IsIsofibration diff --git a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean index 9cd27f1b..6e9bd7a6 100644 --- a/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean +++ b/HoTTLean/Grothendieck/Groupoidal/IsPullback.lean @@ -108,8 +108,30 @@ 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) + + +def compGrothendieck.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) + --pre F G ⋙ forget = forget ⋙ G + (by simp[Functor.Groupoidal.pre_comp_forget]) + --toPGrpd F ⋙ PGrpd.forgetToGrpd = forget ⋙ F + (by simp[Functor.Groupoidal.toPGrpd_forgetToGrpd]) + (by apply Functor.Groupoidal.isPullback) + (by + have e : pre F G ⋙ toPGrpd F = toPGrpd (G ⋙ F) := by rfl + simp[e] + apply Functor.Groupoidal.isPullback) + + + + end + section variable {Γ : Type u} [Category.{v} Γ] From 8b39a4acf6369b2c219da84092e9c453a6e85310 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 23 Oct 2025 11:23:38 -0400 Subject: [PATCH 52/59] pb before golf --- HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean index 21e2e090..e43b75d3 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/Functor/IsPullback.lean @@ -492,7 +492,7 @@ lemma isoIsPullback.invCompFst {P P' X Y Z : Type*} [Category P] [Category P'] 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) + {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 @@ -505,7 +505,7 @@ lemma isoIsPullback.homCompLeft {P P' X Y Z : Type*} [Category P] [Category P'] 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} {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 From 7aa1dfcde19349d2194596c726051ed27c8a03a5 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Thu, 23 Oct 2025 13:52:27 -0400 Subject: [PATCH 53/59] ungolfed pb --- .../CategoryTheory/SplitIsofibration.lean | 37 +++++++++++++------ 1 file changed, 25 insertions(+), 12 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 293085be..c49bb68e 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -414,6 +414,24 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E := 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 + conv => lhs ; rhs; rw[← inv_comp_forget I (F := F)] + simp + + +-- lemma grothendieckClassifierIso.hom' : +-- (grothendieckClassifierIso I).hom = +-- Groupoidal.functorIsoFrom (fun x => Fiber.fiberInclusion) +-- (hom.hom I) sorry sorry:= by +-- simp[grothendieckClassifierIso,functorIsoFrom,Grothendieck.functorIsoFrom, +-- ] +-- sorry + end def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : @@ -785,17 +803,7 @@ def ofIsPullback {A B A' B' : Type u} [Groupoid.{v} A] [Groupoid.{v} B] [Groupoi let i0 : Functor.Groupoidal IF.classifier ≅≅ A := Functor.SplitIsofibration.grothendieckClassifierIso .. have e0 : i0.hom ⋙ F = Groupoidal.forget := by - simp[i0] - - sorry - -- have p1 : Functor.IsPullback (Libya := A') (Egypt := PGrpd) - -- (top ⋙ i0.hom ⋙ Groupoidal.toPGrpd IF.classifier) - -- F' PGrpd.forgetToGrpd (bot ⋙ IF.classifier) - -- := sorry - -- have p2 : Functor.IsPullback - -- (Groupoidal.toPGrpd (bot ⋙ IF.classifier)) - -- Groupoidal.forget PGrpd.forgetToGrpd (bot ⋙ IF.classifier) - -- := sorry + simp[i0,grothendieckClassifierIso.hom_comp_self ] have q2 : Functor.IsPullback (Libya := A') (Egypt := A) top F' F bot @@ -804,7 +812,10 @@ def ofIsPullback {A B A' B' : Type u} [Groupoid.{v} A] [Groupoid.{v} B] [Groupoi Groupoidal.forget Groupoidal.forget bot := by apply Groupoidal.compGrothendieck.isPullback let d := IsPullback.IsPullback.botDegenerate e0.symm - have paste := Functor.IsPullback.Paste.horiz sorry sorry d gpb + have eq1 : Groupoidal.pre IF.classifier bot ⋙ Groupoidal.forget = Groupoidal.forget ⋙ bot := by + simp[Groupoidal.pre_comp_forget] + + have paste := Functor.IsPullback.Paste.horiz eq1 (by simp[e0]) d gpb simp[Functor.id_comp] at paste have q1 : Functor.IsPullback (Groupoidal.pre IF.classifier bot ⋙ i0.hom) @@ -860,6 +871,8 @@ instance : IsIsofibration.IsMultiplicative := by infer_instance instance : IsIsofibration.HasObjects := by + dsimp [IsIsofibration] + infer_instance sorry section From 819b2eefba1529910d261c160a457aff276dc84a Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 23 Oct 2025 14:11:51 -0400 Subject: [PATCH 54/59] chore: golf ofIsPullback --- .../CategoryTheory/SplitIsofibration.lean | 861 +++++------------- 1 file changed, 224 insertions(+), 637 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index c49bb68e..f6050a0e 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -12,6 +12,13 @@ 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 @@ -65,8 +72,6 @@ structure ClovenIsofibration (F : C ⥤ D) where liftIso_IsIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : IsIso (liftIso f hX') - - section variable {F : C ⥤ D} (I : ClovenIsofibration F) @@ -76,7 +81,6 @@ instance {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : instance liftIso_IsIso {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 ClovenIsofibration.obj_liftObj {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X) : F.obj (I.liftObj f hX') = Y := @@ -94,6 +98,7 @@ lemma ClovenIsofibration.map_liftIso' {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} eqToHom hX' ≫ f ≫ eqToHom (by simp[obj_liftObj]) := by simp[← map_liftIso I f hX'] +@[simp] lemma ClovenIsofibration.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' @@ -108,49 +113,44 @@ lemma ClovenIsofibration.eqToHom_comp_liftIso {X Y : D} (f : X ⟶ Y) [IsIso f] end -structure SplitIsofibration {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] - (F : C ⥤ D) extends ClovenIsofibration F where - liftObj_id {X : D} {X' : C} (hX' : F.obj X' = X) : liftObj (𝟙 X) hX' = X' - liftIso_id {X : D} {X' : C} (hX' : F.obj X' = X) : liftIso (𝟙 X) hX' = +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' : liftObj f hX' = Y') : liftObj (f ≫ g) hX' = - liftObj g (X' := Y') (toClovenIsofibration.liftObj_comp_aux f hX' Y' hY') + (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' : liftObj f hX' = Y') : liftIso (f ≫ g) hX' = - liftIso f hX' ≫ eqToHom hY' ≫ - liftIso g (X' := Y') (toClovenIsofibration.liftObj_comp_aux f hX' Y' hY') ≫ - eqToHom (liftObj_comp f g hX' Y' hY').symm - + (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 -namespace SplitIsofibration -open ClovenIsofibration +namespace ClovenIsofibration + +open IsSplit @[simp] lemma liftObj_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] - (F : C ⥤ D) (I : SplitIsofibration F) {X Y : D} (h : X = Y) {X' : C} + {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 [SplitIsofibration.liftObj_id] + simp [IsSplit.liftObj_id] @[simp] lemma liftIso_eqToHom {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] (F : C ⥤ D) - (I : SplitIsofibration F) {X Y : D} (h : X = Y) {X' : C} (hX' : F.obj X' = X) : + (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 [SplitIsofibration.liftIso_id] + simp [IsSplit.liftIso_id] section variable {Γ : Type u} {E : Type u} [Groupoid.{v} Γ] [Groupoid.{v} E] {F : E ⥤ Γ} - (I : SplitIsofibration F) - - + (I : ClovenIsofibration F) - -/-- Any isofibration `F : E ⥤ Γ` of groupoids is classified by a functor `classifier : Γ ⥤ Grpd`. --/ def classifier.map.obj {X Y : Γ} (f : X ⟶ Y) (a : F.Fiber X) : F.Fiber Y := ⟨I.liftObj f a.2, ClovenIsofibration.obj_liftObj ..⟩ @@ -169,20 +169,17 @@ def classifier.map.map {X Y} (f: X ⟶ Y) {a b : F.Fiber X} (m : a ⟶ b) : 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[classifier.map.map] - simp[Fiber.fiberInclusion] - --simp[CategoryStruct.id] - simp[classifier.map.obj] + 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] - --simp[CategoryStruct.comp] @[simps] def classifier.map {X Y} (f : X ⟶ Y) : F.Fiber X ⥤ F.Fiber Y where @@ -191,35 +188,32 @@ def classifier.map {X Y} (f : X ⟶ Y) : F.Fiber X ⥤ F.Fiber Y where 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, I.liftObj_id] + simp [map.obj, liftObj_id] · intro a b f simp ext - simp [map.map, I.liftIso_id, eqToHom_map, Grpd.id_eq_id, ← heq_eq_eq] - --rfl - + 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, I.liftObj_comp] + simp[map.obj, liftObj_comp] · intro a b f simp ext - simp [map.map, eqToHom_map, Grpd.id_eq_id, ← heq_eq_eq,← Category.assoc] - simp[I.liftIso_comp,← Category.assoc] - --congr 1 - --simp[Category.assoc] - --congr - -- simp[] - - + 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) @@ -233,68 +227,33 @@ lemma fiberInclusion_obj_classifier_map_obj {x y} (f : x ⟶ y) (p) : open CategoryTheory.Functor.Groupoidal -/-- The Grothendieck construction on the classifier is isomorphic to `E`. -TODO: add commuting triangles for `Grothendieck.forget` and `F` with `.hom` and `.inv`. -TODO: draw pullback diagram. -/ - 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 +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] - - -/- - -Want: F.obj ↑p1.fiber = p1.base - -p1 : ∫ I.classifier - -p1.base : Γ - -p1.fiber : I.classifier.obj p1.base - - Grpd.of (F.Fiber p1.base) = -I.classifier.obj p1.base = F.Fiber p1.base - -p1.fiber : F.Fiber p1.base - -F.obj p1.fiber = p1.base - --/ -#check Functor.ext 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 - + (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] )) - - + (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] @@ -307,16 +266,14 @@ def grothendieckClassifierIso.hom.hom {X Y} (f : X ⟶ Y) : 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]) + (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 - -- simp[classifier,classifier.map.obj] refine @Fiber.homMk _ _ _ _ F (F.obj Y) _ _ ?_ ?_ · exact CategoryTheory.inv (I.liftIso (F.map f) rfl) ≫ f · simp @@ -328,7 +285,7 @@ def grothendieckClassifierIso.inv.fibMap {X Y}(f : X ⟶ Y) : lemma grothendieckClassifierIso.inv.fibMap_id (x : E) : inv.fibMap I (𝟙 x) = eqToHom (by simp) := by apply Fiber.hom_ext - simp [inv.fibMap] + simp only [comp_obj, comp_map, fibMap, Fiber.fiberInclusion_homMk, Category.comp_id] rw![Functor.map_id,liftIso_id] simp[inv_eqToHom,eqToHom_map] @@ -336,12 +293,10 @@ lemma grothendieckClassifierIso.inv.fibMap_comp {x y z : E} (f : x ⟶ y) (g : y 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[inv.fibMap] + simp only [comp_obj, comp_map, fibMap] apply Fiber.hom_ext - rw![Functor.map_comp] - simp[liftIso_comp] - simp[eqToHom_map,classifier,classifier.map.map] - + 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 @@ -351,13 +306,6 @@ lemma ι_classifier_comp_forget {x} : ι I.classifier x ⋙ Groupoidal.forget = · intro p q f simpa using IsHomLift.fac .. -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] - @[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} : @@ -373,6 +321,9 @@ lemma liftIso_map_fiberInclusion_map {S} {X Y : Fiber F S} {X' : E} (f : X ⟶ Y 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]) @@ -403,39 +354,30 @@ def grothendieckClassifierIso : ∫ I.classifier ≅≅ E := apply Fiber.hom_hext any_goals apply Fiber.hext any_goals simp - · rw! [map_liftIso', I.liftObj_comp _ _ _ _ rfl, I.liftObj_comp _ _ _ _ rfl] + · rw! [map_liftIso', liftObj_comp _ _ _ rfl, liftObj_comp _ _ _ rfl] simp [liftObj_eqToHom] - · rw! [map_liftIso', I.liftIso_comp _ _ _ _ rfl, I.liftIso_comp _ _ _ _ rfl] + · 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 [I.liftObj_comp _ _ _ _ rfl, I.liftObj_comp _ _ _ _ rfl] + rw [liftObj_comp _ _ _ rfl, liftObj_comp _ _ _ rfl] simp) - lemma grothendieckClassifierIso.inv_comp_forget : - (grothendieckClassifierIso I).inv ⋙ Groupoidal.forget = F := rfl - + (grothendieckClassifierIso I).inv ⋙ Groupoidal.forget = F := + rfl lemma grothendieckClassifierIso.hom_comp_self : (grothendieckClassifierIso I).hom ⋙ F = Groupoidal.forget := by - conv => lhs ; rhs; rw[← inv_comp_forget I (F := F)] + slice_lhs 2 3 => rw[← inv_comp_forget I (F := F)] simp - --- lemma grothendieckClassifierIso.hom' : --- (grothendieckClassifierIso I).hom = --- Groupoidal.functorIsoFrom (fun x => Fiber.fiberInclusion) --- (hom.hom I) sorry sorry:= by --- simp[grothendieckClassifierIso,functorIsoFrom,Grothendieck.functorIsoFrom, --- ] --- sorry - end +@[simps!] def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : - SplitIsofibration F.hom where + 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]) @@ -444,137 +386,64 @@ def iso {A B : Type u} [Category.{v} A] [Category.{v} B] (F : A ≅≅ B) : rw! (castMode := .all) [F.inv_hom_id]; simp [← heq_eq_eq] rfl) - liftObj_id h := by simp [← h, ← Functor.comp_obj] - liftIso_id := by simp - liftObj_comp := by simp - liftIso_comp := by simp 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) + {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) -def 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 +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) := by infer_instance - -- let tinv := (asIso t).inv - -- let tinv': (x.transport t).base ⟶ x.base := (asIso t).inv - -- let f1 := Groupoidal.toTransport (x.transport t) tinv' - -- exact ⟨f1 ≫ eqToHom - -- (by simp[tinv']; - -- fapply Groupoidal.ext - -- · simp - -- · simp - -- simp[← Functor.comp_obj,← Grpd.comp_eq_comp] - - -- --sorry --previous proof below - -- -- simp only [eqToHom_refl, map_id, Grpd.id_eq_id, Groupoidal.transport_fiber, - -- -- id_obj] - -- -- simp only[← Functor.comp_obj] - -- -- --simp[← Grothendieck.map_comp_eq] - -- -- simp only [← Functor.map_comp,← Grpd.comp_eq_comp] - -- -- simp - -- ) , - -- sorry⟩ - -def forget.liftIso_IsIso {X Y: C} (f : X ⟶ Y) - [IsIso f] {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X) : - IsIso (forget.liftIso f hX') - := by - simp[liftIso] - apply toTransport_IsIso - - -/- -lemma transport_id {X' : F.Groupoidal}: - X'.transport (𝟙 X'.base) = X' := by - fapply Groupoidal.ext - · simp[Groupoidal.transport,Grothendieck.transport,Groupoidal.base] - simp[Groupoidal.fiber,Grpd.forgetToCat,Functor.map_id] - simp[Groupoidal.transport,Grothendieck.transport,Grpd.forgetToCat] - have e: (F.map (𝟙 X'.base)) = Functor.id _ := by simp - simp[e] - - -lemma transport_eqToHom {X: C} {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X): - X'.transport (eqToHom hX') = X' := by - subst hX' - simp[transport_id] - -- fapply Groupoidal.ext - -- · simp[transport_id] - -- -- simp[Groupoidal.base] - -- simp[Groupoidal.fiber,Grpd.forgetToCat,Functor.map_id] - -- have e: (F.map (𝟙 X'.base)) = Functor.id _ := by simp - --simp[e] - - should be in groupoidal file --/ +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] - simp[Groupoidal.transport_eqToHom] - --simp[Groupoidal.transport,Grothendieck.transport] - -/- -lemma toTransport_eqToHom {X: C} {X' : F.Groupoidal} (hX': Groupoidal.forget.obj X' = X): - Groupoidal.toTransport X' (eqToHom hX') = eqToHom (by subst hX'; sorry) := by - apply Groupoidal.toTransport_eqToHom --/ - - -- subst hX' - -- simp[Groupoidal.toTransport,Grothendieck.toTransport] - -- fapply Groupoidal.Hom.ext - -- · simp[Groupoidal.Hom.base,Groupoidal.base] - -- rw![Grothendieck.Hom.base] - -- sorry - -- sorry + 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 - simp[liftIso] + forget.liftIso (𝟙 X) hX' = eqToHom (by simp [forget.liftObj_id]) := by + dsimp [liftIso] rw! (castMode :=.all)[Category.comp_id] - simp[Groupoidal.toTransport_eqToHom] - simp[← heq_eq_eq] + simp only [Groupoidal.toTransport_eqToHom, ← heq_eq_eq, eqRec_heq_iff_heq] congr! - - --conv => rhs ; rw[← toTransport_eqToHom] - - --rw[← toTransport_eqToHom] - - - /-simp only [eqToHom_refl, map_id, Grpd.id_eq_id, Groupoidal.transport_fiber, - -- -- id_obj] - -- -- simp only[← Functor.comp_obj] - -- -- --simp[← Grothendieck.map_comp_eq] - -- -- simp only [← Functor.map_comp,← Grpd.comp_eq_comp] - -- -- simp - -- ) ,-/ - 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') - (h': Y'.base = Y := by simp[]): - forget.liftObj (f ≫ g) hX' = forget.liftObj g h' := by + {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 @@ -585,196 +454,159 @@ lemma forget.liftObj_comp {X Y Z: C} (f : X ⟶ Y) (g : Y ⟶ Z) 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') - (h': Y'.base = Y := by simp[]) - (e : liftObj g h' = liftObj (f ≫ g) hX' := by apply forget.liftObj_comp): - forget.liftIso (f ≫ g) hX' = forget.liftIso f hX' ≫ eqToHom hY' ≫ - forget.liftIso g h' ≫ eqToHom e := by - simp only [liftIso] + 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 - simp[Groupoidal.toTransport_comp] - simp[Groupoidal.toTransport_id] + simp only [liftIso, eqToHom_refl, Groupoidal.toTransport_comp, Groupoidal.toTransport_id, + Category.assoc, eqToHom_trans, Category.id_comp, eqToHom_trans_assoc] congr 2 - simp[← heq_eq_eq,← Category.assoc,liftObj] + 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)] - - rw[Groupoidal.transport_congr (X'.transport (𝟙 X'.base ≫ f)) (X'.transport f) _ - ((𝟙 (X'.transport (𝟙 X'.base ≫ f)).base)) (eqToHom (by simp))] - · simp[Groupoidal.transport_id] - · simp - · simp - - - -- simp[Category.assoc] - -- simp[Groupoidal.toTransport_eqToHom] - - -- simp - -- rw!(castMode :=.all)[Groupoidal.transport_id] - -- rw!(castMode :=.all)[Groupoidal.transport_eqToHom] - -- rw!(castMode :=.all)[← Category.assoc] - -- simp[Groupoidal.toTransport_comp] - -- congr 1 - -- congr 1 - -- --simp[Category.assoc] - -- simp[← heq_eq_eq] - -- simp[← Category.assoc] - -- rw!(castMode :=.all)[Groupoidal.transport_eqToHom] - - --simp[heq_comp_eqToHom_iff] this one is autosimp - --conv in (eqToHom sorry ≫ f ≫ g) => simp[← CategoryStruct.assoc] - - - -def forget : - SplitIsofibration (Groupoidal.forget (F := F)) where - liftObj f := forget.liftObj f - liftIso f := forget.liftIso f - isHomLift f := forget.isHomLift f - liftIso_IsIso f := forget.liftIso_IsIso f - liftObj_id f := forget.liftObj_id f - liftIso_id f := forget.liftIso_id f - liftObj_comp {X Y Z} f _ g _ := by - intro X' hX' Y' hY' - apply forget.liftObj_comp - assumption - liftIso_comp := by - intro X Y Z f i1 g i2 X' hX' Y' hY' - apply forget.liftIso_comp + 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] : SplitIsofibration (𝟭 A) := +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 : SplitIsofibration F) {G : B ⥤ C} (IG : SplitIsofibration G) - + (IF : ClovenIsofibration F) {G : B ⥤ C} (IG : ClovenIsofibration G) -def comp.liftObj {X Y: C} (f: X ⟶ Y) [i: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 +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] -lemma comp.obj_liftObj {X Y: C} (f: X ⟶ Y) [i: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 -def comp.liftIso {X Y: C} (f: X ⟶ Y) [i: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 - -def comp.isHomLift {X Y: C} (f: X ⟶ Y) [i:IsIso f] {X': A} (hX': (F ⋙ G).obj X' = X): - (F ⋙ G).IsHomLift f (comp.liftIso IF IG f hX') := by +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 - · simp[comp.liftIso] - let e := ClovenIsofibration.map_liftIso' (F := F) - rw[e] - simp[eqToHom_map] - simp[ClovenIsofibration.map_liftIso'] + · 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] + · 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] -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] +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 - simp [comp.liftIso] - rw! (castMode := .all) [IG.liftIso_id] - simp [← heq_eq_eq] + 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): +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, SplitIsofibration.liftObj_comp, + simp only [liftObj, liftIso_comp, eqToHom_refl, Category.id_comp, IsSplit.liftObj_comp, liftObj_eqToHom] congr! - simp[ClovenIsofibration.obj_liftObj] - - -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] - + 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 - simp only [liftObj, liftIso] - have e:= @SplitIsofibration.liftIso_comp (f:= f) (g:= g) _ _ _ _ G IG X Y Z _ _ (F.obj X') hX' (IG.liftObj f hX') rfl - rw![e,eqToHom_refl,Category.id_comp] - simp only [SplitIsofibration.liftIso_comp, eqToHom_refl, liftIso_eqToHom, eqToHom_trans, - Category.id_comp, Category.assoc] - congr 1 - simp only [← heq_eq_eq, heq_eqToHom_comp_iff, heq_comp_eqToHom_iff, comp_eqToHom_heq_iff] - congr! - · subst hY' - simp[liftObj] --do not know why it works, but it did - subst hY' - simp[liftObj] - + (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 -/-- `IsMultiplicative` 1/2 -/ -def comp : - SplitIsofibration (F ⋙ G) where - liftObj := comp.liftObj IF IG - liftIso := comp.liftIso IF IG - isHomLift := comp.isHomLift IF IG +instance : IsSplit (comp IF IG) where liftObj_id := by - intro X X' hX' - apply comp.liftObj_id + intro X X' hX' + apply comp.liftObj_id liftIso_id := by - intro X X' hX' - apply comp.liftIso_id + intro X X' hX' + apply comp.liftIso_id liftObj_comp := by - intro X Y Z f i1 g i2 X' hX' Y' hY' - simp only [comp.liftObj_comp] - congr + 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' - simp only [comp.liftIso_comp] - congr! - liftIso_IsIso := by - intro X Y f i1 X' hX' - simp[comp.liftIso] - apply liftIso_IsIso + intro X Y Z f i1 g i2 X' hX' Y' hY' + apply comp.liftIso_comp +section isoComp -instance isoComp_SplitIsofibration {A A' B : Type u} [Category.{v} A] [Category.{v} A'] - [Category.{v} B] - (i : A' ≅≅ A) (F: A ⥤ B) (IF: SplitIsofibration F): SplitIsofibration (i.hom ⋙ F) := sorry +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) -instance iso_SplitIsofibration {A A' B : Type u} [Category.{v} A] [Category.{v} A'] - [Category.{v} B] - (i : A' ≅≅ A) (F: A ⥤ B) (IF: SplitIsofibration F): SplitIsofibration (i.hom ⋙ F) := sorry +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 + -- 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) : @@ -787,275 +619,30 @@ end -- liftObj_comp := sorry -- liftIsoComp := sorry -section -/-- `IsStableUnderBaseChange` -/ - 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 : SplitIsofibration F) : - SplitIsofibration F' := by - --have c:= SplitIsofibration.classifier IF - --have p : Functor.Groupoidal IF.classifier ≅≅ A := sorry - have Ichar : SplitIsofibration (Groupoidal.forget (F := IF.classifier)) := by - apply Functor.SplitIsofibration.forget - have Ichar' : SplitIsofibration (Groupoidal.forget (F := bot ⋙ IF.classifier)) := by - apply Functor.SplitIsofibration.forget - let i0 : Functor.Groupoidal IF.classifier ≅≅ A := - Functor.SplitIsofibration.grothendieckClassifierIso .. - have e0 : i0.hom ⋙ F = Groupoidal.forget := by - simp[i0,grothendieckClassifierIso.hom_comp_self ] - - have q2 : Functor.IsPullback (Libya := A') (Egypt := A) - top F' F bot - := isPullback - have gpb : Functor.IsPullback (Groupoidal.pre IF.classifier bot) - Groupoidal.forget Groupoidal.forget bot := by - apply Groupoidal.compGrothendieck.isPullback - let d := IsPullback.IsPullback.botDegenerate e0.symm + (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 paste := Functor.IsPullback.Paste.horiz eq1 (by simp[e0]) d gpb - simp[Functor.id_comp] at paste - have q1 : Functor.IsPullback - (Groupoidal.pre IF.classifier bot ⋙ i0.hom) - (Groupoidal.forget (F := (bot ⋙ IF.classifier))) F bot - := paste + 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 q2 q1 - have e: F' = j.hom ⋙ (Groupoidal.forget (F := bot ⋙ IF.classifier)) := by - symm - have e1 := IsPullback.isoIsPullback.homCompRight' q2 q1 (hom := j.hom) (by simp[j]) - exact e1 - -- let i : A' ≅≅ Functor.Groupoidal (F := bot ⋙ IF.classifier) := - -- Functor.IsPullback.isoIsPullback p1 p2 - -- have eq: F' = i.hom ⋙ (Groupoidal.forget (F := bot ⋙ IF.classifier)) := by - -- symm - -- --simp[i] - -- have e1 := IsPullback.isoIsPullback.homCompLeft' p1 p2 (hom := i.hom) (by simp[i]) - - -- sorry - simp[e] - apply iso_SplitIsofibration j (Groupoidal.forget (F := bot ⋙ IF.classifier)) - exact Ichar' - - -end -#exit -namespace IsIsofibration - -def isofibration B A : Grpd {F : B ⟶ A} (hF : IsIsofibration F) : F.Isofibration := sorry - -/-- The Grothendieck construction on the classifier is isomorphic to `E`, -now as objects in `Grpd`. -/ -def grothendieckClassifierIso {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : - Grpd.of (∫ hF.isofibration.classifier) ≅ B := - Grpd.mkIso (Functor.Isofibration.grothendieckClassifierIso ..) - --- lemma grothendieckClassifierIso_hom_comp_eq_forget {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : --- hF.grothendieckClassifierIso.hom ⋙ F = homOf Functor.Groupoidal.forget := --- sorry - -lemma grothendieckClassifierIso_inv_comp_forget {B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) : - hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := - sorry - -end IsIsofibration + 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 : IsIsofibration.IsStableUnderBaseChange := by - dsimp [IsIsofibration] - infer_instance - -instance : IsIsofibration.IsMultiplicative := by - dsimp [IsIsofibration] - infer_instance - -instance : IsIsofibration.HasObjects := by - dsimp [IsIsofibration] +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 - sorry - -section - -attribute [local instance] Grpd.IsIsofibration.isofibration - -open Functor.Isofibration - -def strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) (G : C ⟶ B) : - C ⟶ Grpd.of (∫ classifier (hF.isofibration)) := - G ≫ hF.grothendieckClassifierIso.inv - -def isIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : IsIsofibration (strictify hF G) := sorry - -def isofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : (strictify hF G).Isofibration := sorry - -/-- 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 : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : Grpd := - Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.isofibration.classifier) - (classifier (isofibration_strictify hF hG))) - -/-- 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 : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration 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 : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : Over A := - Over.mk (pushforwardHom hF hG) - -lemma pushforward.hom {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : - (pushforward hF hG).hom = pushforwardHom .. := rfl - -open Limits in -lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : IsIsofibration 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 : IsIsofibration F) (σ : Over A) : - IsPullback (homOf (pre hF.isofibration.classifier σ.hom)) (homOf Functor.Groupoidal.forget) - (homOf Functor.Groupoidal.forget) (homOf σ.hom) := by - have outer_pb := Functor.Groupoidal.isPullback (σ.hom ⋙ hF.isofibration.classifier) - have right_pb := Functor.Groupoidal.isPullback (hF.isofibration.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 pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : IsIsofibration F) (σ : Over A) : - Grpd.of (∫ σ.hom ⋙ hF.isofibration.classifier) ≅ Limits.pullback σ.hom F := - (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) - -open GroupoidModel.FunctorOperation.pi in -/-- `∫ σ.hom ⋙ hF.isofibration.classifier` is the pullback of `F` along `σ`, -`∫ (isofibration_strictify hF hG).classifier` is isomorphic to `G`. -So up to isomorphism this is the hom set bijection we want. -/ -def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) (σ : Over A) : - (σ ⟶ pushforward hF hG) ≃ - {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // - f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } where - toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ - invFun f := Over.homMk (equivInv _ f.1 f.2) - (equivInv_comp_forget ..) - left_inv f := by - ext - simp [equivInv_equivFun] - right_inv f := by - ext - simp [equivFun_equivInv] - -def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) (σ : Over A) : - { f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // - f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom } ≃ - ((Over.pullback F).obj σ ⟶ Over.mk G) where - toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ - ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry - invFun f := ⟨(pullbackIsoGrothendieck hF σ).hom ≫ f.left ≫ - ((isIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ - left_inv := sorry - right_inv := sorry - -open GroupoidModel.FunctorOperation.pi in -/-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ -def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) (σ : Over A) : - (σ ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := - calc (σ ⟶ pushforward hF hG) - _ ≃ {f : ∫ σ.hom ⋙ hF.isofibration.classifier ⥤ ∫ (isofibration_strictify hF hG).classifier // - (f ⋙ Functor.Groupoidal.forget = pre hF.isofibration.classifier σ.hom)} := - pushforwardHomEquivAux1 .. - _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. - - - -/-- Naturality in the universal property of the pushforward. -/ -lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration 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 - sorry - - -def pushforward_isPushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : IsPushforward F (Over.mk G) (pushforward hF hG) where - homEquiv := pushforwardHomEquiv .. - homEquiv_comp f g := pushforwardHomEquiv_comp hF hG f g - -instance : IsIsofibration.HasPushforwards IsIsofibration := - fun F _ G => { - has_representation := ⟨pushforward F.2 G.2, ⟨pushforward_isPushforward F.2 G.2⟩⟩ } - -def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : IsIsofibration F) - (G: Over B) (hG : IsIsofibration 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 isofibration. --- (If we manage to directly define the pushforward --- as a grothendieck construction) -theorem isIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : IsIsofibration F) {G : C ⟶ B} - (hG : IsIsofibration G) : IsIsofibration (pushforwardHom hF hG) := - sorry - --- FIXME. For some reason needed in the proof --- `IsIsofibration.IsStableUnderPushforward IsIsofibration` -instance IsIsofibration.RespectsIso : IsIsofibration.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. Isofibrations are stable under isomorphism (this is in mathlib, for any `rlp`) - `MorphismProperty.rlp_isMultiplicative` - `MorphismProperty.respectsIso_of_isStableUnderComposition` - 3. The chosen pushforward is an isofibration `isIsofibration_pushforward` -/ - -instance : IsIsofibration.IsStableUnderPushforward IsIsofibration 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 : IsIsofibration (pushforwardHom (F.snd) (G.snd)) := by - apply isIsofibration_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 (IsIsofibration.RespectsIso).precomp - assumption From ad15b3b9a0afc21ac8b39037b769e0411dc3cc4e Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 23 Oct 2025 13:55:38 -0400 Subject: [PATCH 55/59] . --- .../CategoryTheory/SplitIsofibration.lean | 19 +++-- HoTTLean/Groupoids/SplitIsofibration.lean | 80 ++++++++++--------- 2 files changed, 51 insertions(+), 48 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index f6050a0e..b6af4f35 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -72,47 +72,48 @@ structure ClovenIsofibration (F : C ⥤ D) where 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 {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 liftIso_IsIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} (hX' : F.obj X' = X): +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 ClovenIsofibration.obj_liftObj {X Y : D} (f : X ⟶ Y) [IsIso f] +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 ClovenIsofibration.map_liftIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} +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 ClovenIsofibration.map_liftIso' {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} +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 ClovenIsofibration.liftObj_comp_aux {X Y : D} (f : X ⟶ Y) [IsIso f] {X' : C} +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 ClovenIsofibration.eqToHom_comp_liftIso {X Y : D} (f : X ⟶ Y) [IsIso f] {X' X'' : C} +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 -end - 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' @@ -129,8 +130,6 @@ class IsSplit {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] end -namespace ClovenIsofibration - open IsSplit @[simp] diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean index b6376c0d..9bf27179 100644 --- a/HoTTLean/Groupoids/SplitIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -69,18 +69,20 @@ open Functor.Groupoidal namespace Grpd def SplitIsofibration : MorphismProperty Grpd := - fun _ _ F => Nonempty F.SplitIsofibration + fun _ _ F => ∃ I : F.ClovenIsofibration, I.IsSplit namespace SplitIsofibration variable {B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) -def splitClovenIsofibration : F.SplitIsofibration := Classical.choice hF +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.splitClovenIsofibration.classifier) ≅ B := - Grpd.mkIso (Functor.SplitIsofibration.grothendieckClassifierIso ..) +def grothendieckClassifierIso : Grpd.of (∫ hF.splitIsofibration.classifier) ≅ B := + Grpd.mkIso (Functor.ClovenIsofibration.grothendieckClassifierIso ..) lemma grothendieckClassifierIso_inv_comp_forget : hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := @@ -90,43 +92,45 @@ end SplitIsofibration instance : SplitIsofibration.IsStableUnderBaseChange.{u,u} where of_isPullback pb hG := - ⟨ Functor.SplitIsofibration.ofIsPullback _ _ _ _ - (Grpd.functorIsPullback pb) hG.splitClovenIsofibration ⟩ + ⟨ Functor.ClovenIsofibration.ofIsPullback _ _ _ _ + (Grpd.functorIsPullback pb) hG.splitIsofibration, inferInstance ⟩ instance : SplitIsofibration.IsMultiplicative where - id_mem _ := ⟨ Functor.SplitIsofibration.id ⟩ - comp_mem _ _ hF hG := ⟨ Functor.SplitIsofibration.comp - hF.splitClovenIsofibration hG.splitClovenIsofibration ⟩ + 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.SplitIsofibration.iso { + ⟨ 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] }⟩) + inv_hom_id := by simp [← Grpd.comp_eq_comp] }, + inferInstance⟩) instance : SplitIsofibration.HasObjects where obj_mem F G := sorry section -open Functor.SplitIsofibration +open Functor.ClovenIsofibration def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) (G : C ⟶ B) : - C ⟶ Grpd.of (∫ classifier (hF.splitClovenIsofibration)) := + C ⟶ Grpd.of (∫ classifier (hF.splitIsofibration)) := G ≫ hF.grothendieckClassifierIso.inv -def splitClovenIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) - {G : C ⟶ B} (hG : SplitIsofibration G) : (strictify hF G).SplitIsofibration := sorry +def splitIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) + {G : C ⟶ B} (hG : SplitIsofibration G) : (strictify hF G).ClovenIsofibration := + sorry /-- 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 <| ∫ (GroupoidModel.FunctorOperation.pi (hF.splitClovenIsofibration.classifier) - (classifier (splitClovenIsofibration_strictify hF hG))) + Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.splitIsofibration.classifier) + (classifier (splitIsofibration_strictify hF hG))) /-- The morphism part (a functor) of the pushforward along `F`, of `G`. This is defined as the forgetful functor from the Grothendieck construction. -/ @@ -153,11 +157,11 @@ lemma pullback_isPullback {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : O (by simp) lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : Over A) : - IsPullback (homOf (pre hF.splitClovenIsofibration.classifier σ.hom)) + 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.splitClovenIsofibration.classifier) - have right_pb := Functor.Groupoidal.isPullback (hF.splitClovenIsofibration.classifier) + 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 @@ -176,19 +180,19 @@ lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitIsofibration F) ( The two versions of the pullback are isomorphic. -/ def pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : Over A) : - Grpd.of (∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier) ≅ Limits.pullback σ.hom F := + Grpd.of (∫ σ.hom ⋙ hF.splitIsofibration.classifier) ≅ Limits.pullback σ.hom F := (pre_classifier_isPullback hF σ).isoIsPullback _ _ (pullback_isPullback hF σ) open GroupoidModel.FunctorOperation.pi in -/-- `∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier` is the pullback of `F` along `σ`, -`∫ (splitClovenIsofibration_strictify hF hG).classifier` is isomorphic to `G`. +/-- `∫ σ.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. -/ def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} (hG : SplitIsofibration G) (σ : Over A) : (σ ⟶ pushforward hF hG) ≃ - {f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ - ∫ (splitClovenIsofibration_strictify hF hG).classifier // - f ⋙ Functor.Groupoidal.forget = pre hF.splitClovenIsofibration.classifier σ.hom } where + {f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ + ∫ (splitIsofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } where toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ invFun f := Over.homMk (equivInv _ f.1 f.2) (equivInv_comp_forget ..) @@ -201,14 +205,14 @@ def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} (hG : SplitIsofibration G) (σ : Over A) : - { f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ - ∫ (splitClovenIsofibration_strictify hF hG).classifier // - f ⋙ Functor.Groupoidal.forget = pre hF.splitClovenIsofibration.classifier σ.hom } ≃ + { f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ + ∫ (splitIsofibration_strictify hF hG).classifier // + f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) where toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ - ((splitClovenIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry + ((splitIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry invFun f := ⟨ (pullbackIsoGrothendieck hF σ).hom ⋙ f.left ⋙ - ((splitClovenIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ + ((splitIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ left_inv := sorry right_inv := sorry @@ -218,9 +222,9 @@ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C (hG : SplitIsofibration G) (σ : Over A) : (σ ⟶ pushforward hF hG) ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := calc (σ ⟶ pushforward hF hG) - _ ≃ {f : ∫ σ.hom ⋙ hF.splitClovenIsofibration.classifier ⥤ - ∫ (splitClovenIsofibration_strictify hF hG).classifier // - (f ⋙ Functor.Groupoidal.forget = pre hF.splitClovenIsofibration.classifier σ.hom)} := + _ ≃ {f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ + ∫ (splitIsofibration_strictify hF hG).classifier // + (f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom)} := pushforwardHomEquivAux1 .. _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. @@ -254,10 +258,10 @@ def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitIsofibration F homEquiv_comp f g := by apply pushforwardHomEquiv_comp .. } ) --- This should follow from `Groupoidal.forget` being an splitClovenIsofibration. +-- This should follow from `Groupoidal.forget` being an splitIsofibration. -- (If we manage to directly define the pushforward -- as a grothendieck construction) -theorem splitClovenIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) +theorem splitIsofibration_pushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} (hG : SplitIsofibration G) : SplitIsofibration (pushforwardHom hF hG) := sorry @@ -276,7 +280,7 @@ instance SplitIsofibration.RespectsIso : SplitIsofibration.RespectsIso := inferI 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 splitClovenIsofibration `splitClovenIsofibration_pushforward` -/ + 3. The chosen pushforward is an splitIsofibration `splitIsofibration_pushforward` -/ instance : SplitIsofibration.IsStableUnderPushforward SplitIsofibration where of_isPushforward F G P := by @@ -284,7 +288,7 @@ instance : SplitIsofibration.IsStableUnderPushforward SplitIsofibration where 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 splitClovenIsofibration_pushforward + apply splitIsofibration_pushforward have e : P = (p.hom).left ≫ (pushforwardHom (F.snd) (G.snd)) := by have ee := Over.w p.hom simp at ee From ab62b096580a143af4a9106074e67a3cff9a374b Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 23 Oct 2025 14:32:36 -0400 Subject: [PATCH 56/59] chore: fix errors in Groupoids.SplitIsofibration --- HoTTLean/Groupoids/SplitIsofibration.lean | 44 ++++++++++++++--------- 1 file changed, 27 insertions(+), 17 deletions(-) diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean index 9bf27179..2e1b33a5 100644 --- a/HoTTLean/Groupoids/SplitIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -120,17 +120,23 @@ def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) (G : C ⟶ C ⟶ Grpd.of (∫ classifier (hF.splitIsofibration)) := G ≫ hF.grothendieckClassifierIso.inv -def splitIsofibration_strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) +def strictifyClovenIsofibration {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} (hG : SplitIsofibration G) : (strictify hF G).ClovenIsofibration := sorry +lemma isSplit_strictifyClovenIsofibration {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) + {G : C ⟶ B} (hG : SplitIsofibration G) : + (strictifyClovenIsofibration hF hG).IsSplit := + sorry + /-- 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 := + have := isSplit_strictifyClovenIsofibration hF hG Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.splitIsofibration.classifier) - (classifier (splitIsofibration_strictify hF hG))) + (classifier (strictifyClovenIsofibration hF hG))) /-- The morphism part (a functor) of the pushforward along `F`, of `G`. This is defined as the forgetful functor from the Grothendieck construction. -/ @@ -189,9 +195,10 @@ open GroupoidModel.FunctorOperation.pi in So up to isomorphism this is the hom set bijection we want. -/ def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} (hG : SplitIsofibration G) (σ : Over A) : + have := isSplit_strictifyClovenIsofibration hF hG (σ ⟶ pushforward hF hG) ≃ {f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ - ∫ (splitIsofibration_strictify hF hG).classifier // + ∫ (strictifyClovenIsofibration hF hG).classifier // f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } where toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ invFun f := Over.homMk (equivInv _ f.1 f.2) @@ -203,30 +210,33 @@ def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G ext simp [equivFun_equivInv] -def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} - (hG : SplitIsofibration G) (σ : Over A) : - { f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ - ∫ (splitIsofibration_strictify hF hG).classifier // - f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } ≃ - ((Over.pullback F).obj σ ⟶ Over.mk G) where - toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ - ((splitIsofibration_strictify hF hG)).grothendieckClassifierIso.hom) sorry - invFun f := ⟨ (pullbackIsoGrothendieck hF σ).hom ⋙ f.left ⋙ - ((splitIsofibration_strictify hF hG)).grothendieckClassifierIso.inv, sorry⟩ - left_inv := sorry - right_inv := sorry +-- def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} +-- (hG : SplitIsofibration G) (σ : Over A) : +-- have := isSplit_strictifyClovenIsofibration hF hG +-- (σ ⟶ pushforward hF hG) ≃ +-- { f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ +-- ∫ (strictifyClovenIsofibration hF hG).classifier // +-- f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } ≃ +-- ((Over.pullback F).obj σ ⟶ Over.mk G) where +-- toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ +-- ((strictifyClovenIsofibration hF hG)).grothendieckClassifierIso.hom) sorry +-- invFun f := ⟨ (pullbackIsoGrothendieck hF σ).hom ⋙ f.left ⋙ +-- ((strictifyClovenIsofibration hF hG)).grothendieckClassifierIso.inv, sorry⟩ +-- left_inv := sorry +-- right_inv := sorry open GroupoidModel.FunctorOperation.pi in /-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ 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) := + have := isSplit_strictifyClovenIsofibration hF hG calc (σ ⟶ pushforward hF hG) _ ≃ {f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ - ∫ (splitIsofibration_strictify hF hG).classifier // + ∫ (strictifyClovenIsofibration hF hG).classifier // (f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom)} := pushforwardHomEquivAux1 .. - _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := pushforwardHomEquivAux2 .. + _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := sorry --pushforwardHomEquivAux2 .. /-- Naturality in the universal property of the pushforward. -/ From a9a31a76450f8abd1151f1a3c0db2f1c495bf75b Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 23 Oct 2025 16:58:58 -0400 Subject: [PATCH 57/59] refactor: Grpd splitIsofibrations pushforward through general SplitIsofibration --- .../CategoryTheory/SplitIsofibration.lean | 160 +++++++++++++++- HoTTLean/Groupoids/Pi.lean | 55 +++++- HoTTLean/Groupoids/SplitIsofibration.lean | 175 ++++++------------ 3 files changed, 263 insertions(+), 127 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index b6af4f35..96e41587 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -3,6 +3,8 @@ 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 @@ -61,10 +63,11 @@ instance {X : Γ} : IsGroupoid (F.Fiber X) where instance {X : Γ} : Groupoid (F.Fiber X) := Groupoid.ofIsGroupoid end Fiber + section -variable {C : Type u} {D : Type u₁} [Category.{v} C] [Category.{v₁} D] -structure ClovenIsofibration (F : C ⥤ D) where +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) : @@ -76,7 +79,8 @@ namespace ClovenIsofibration section -variable {F : C ⥤ D} (I : ClovenIsofibration F) +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' @@ -478,11 +482,8 @@ instance : IsSplit (forget F) where 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 _) @@ -645,3 +646,150 @@ instance {A B A' B' : Type u} [Groupoid.{v} A] [Groupoid.{v} B] [Groupoid.{v} A' 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] + +def pushforward.strictifyClovenIsofibration : (strictify IF G).ClovenIsofibration := + let := IG -- TODO: remove + sorry + +instance : (pushforward.strictifyClovenIsofibration IF IG).IsSplit := + sorry + +/-- 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 + +-- /-- The morphism part (a functor) of the pushforward along `F`, of `G`. +-- This is defined as the forgetful functor from the Grothendieck construction. -/ +-- abbrev pushforwardHom : pushforwardLeft IF IG ⥤ A := +-- Functor.Groupoidal.forget + +-- /-- The pushforward along `F`, of `G`, as an object in the over category. -/ +-- abbrev pushforward : 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 pullbackIsoGrothendieck {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 σ) + + +/-- `∫ σ.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. -/ +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] + +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 + slice_lhs 2 3 => 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 := sorry + right_inv := sorry + +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 .. + +/-- 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 + sorry + +end pushforward + +end ClovenIsofibration +end +end Functor +end CategoryTheory diff --git a/HoTTLean/Groupoids/Pi.lean b/HoTTLean/Groupoids/Pi.lean index f704ca0a..a17b7d60 100644 --- a/HoTTLean/Groupoids/Pi.lean +++ b/HoTTLean/Groupoids/Pi.lean @@ -964,9 +964,58 @@ end end -end pi - -end FunctorOperation +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_naturality])) + (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_naturality, 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] + +-- TODO: work out naturality equations for this bijection + +end FunctorOperation.pi section variable {Γ : Ctx} diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean index 2e1b33a5..af6cb28f 100644 --- a/HoTTLean/Groupoids/SplitIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -5,63 +5,6 @@ universe w v u v₁ u₁ v₂ u₂ v₃ u₃ noncomputable section -namespace GroupoidModel.FunctorOperation.pi - -open CategoryTheory Functor.Groupoidal - -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_naturality])) - (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_naturality, 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] - --- TODO: work out naturality equations for this bijection - -end GroupoidModel.FunctorOperation.pi - namespace CategoryTheory open Functor.Groupoidal @@ -116,27 +59,25 @@ section open Functor.ClovenIsofibration -def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) (G : C ⟶ B) : - C ⟶ Grpd.of (∫ classifier (hF.splitIsofibration)) := - G ≫ hF.grothendieckClassifierIso.inv +-- def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) (G : C ⟶ B) : +-- C ⟶ Grpd.of (∫ classifier (hF.splitIsofibration)) := +-- G ≫ hF.grothendieckClassifierIso.inv -def strictifyClovenIsofibration {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) - {G : C ⟶ B} (hG : SplitIsofibration G) : (strictify hF G).ClovenIsofibration := - sorry +-- def strictifyClovenIsofibration {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) +-- {G : C ⟶ B} (hG : SplitIsofibration G) : (strictify hF G).ClovenIsofibration := +-- sorry -lemma isSplit_strictifyClovenIsofibration {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) - {G : C ⟶ B} (hG : SplitIsofibration G) : - (strictifyClovenIsofibration hF hG).IsSplit := - sorry +-- lemma isSplit_strictifyClovenIsofibration {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) +-- {G : C ⟶ B} (hG : SplitIsofibration G) : +-- (strictifyClovenIsofibration hF hG).IsSplit := +-- sorry /-- 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 := - have := isSplit_strictifyClovenIsofibration hF hG - Grpd.of <| ∫ (GroupoidModel.FunctorOperation.pi (hF.splitIsofibration.classifier) - (classifier (strictifyClovenIsofibration hF hG))) + 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. -/ @@ -150,16 +91,16 @@ abbrev pushforward {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B 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 + (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 ) + (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) : @@ -185,59 +126,58 @@ lemma pre_classifier_isPullback {B A} {F : B ⟶ A} (hF : SplitIsofibration F) ( σ The two versions of the pullback are isomorphic. -/ -def pullbackIsoGrothendieck {B A} {F : B ⟶ A} (hF : SplitIsofibration F) (σ : Over A) : +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 σ) -open GroupoidModel.FunctorOperation.pi in -/-- `∫ σ.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. -/ -def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} - (hG : SplitIsofibration G) (σ : Over A) : - have := isSplit_strictifyClovenIsofibration hF hG - (σ ⟶ pushforward hF hG) ≃ - {f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ - ∫ (strictifyClovenIsofibration hF hG).classifier // - f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } where - toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ - invFun f := Over.homMk (equivInv _ f.1 f.2) - (equivInv_comp_forget ..) - left_inv f := by - ext - simp [equivInv_equivFun] - right_inv f := by - ext - simp [equivFun_equivInv] - --- def pushforwardHomEquivAux2 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} +lemma grothendieckIsoPullback_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 σ) + +-- open GroupoidModel.FunctorOperation.pi in +-- /-- `∫ σ.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. -/ +-- def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} -- (hG : SplitIsofibration G) (σ : Over A) : -- have := isSplit_strictifyClovenIsofibration hF hG -- (σ ⟶ pushforward hF hG) ≃ --- { f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ +-- {f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ -- ∫ (strictifyClovenIsofibration hF hG).classifier // --- f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } ≃ --- ((Over.pullback F).obj σ ⟶ Over.mk G) where --- toFun f := Over.homMk ((pullbackIsoGrothendieck hF σ).inv ≫ Grpd.homOf f.1 ≫ --- ((strictifyClovenIsofibration hF hG)).grothendieckClassifierIso.hom) sorry --- invFun f := ⟨ (pullbackIsoGrothendieck hF σ).hom ⋙ f.left ⋙ --- ((strictifyClovenIsofibration hF hG)).grothendieckClassifierIso.inv, sorry⟩ --- left_inv := sorry --- right_inv := sorry - -open GroupoidModel.FunctorOperation.pi in +-- f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } where +-- toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ +-- invFun f := Over.homMk (equivInv _ f.1 f.2) +-- (equivInv_comp_forget ..) +-- left_inv f := by +-- ext +-- simp [equivInv_equivFun] +-- right_inv f := by +-- ext +-- simp [equivFun_equivInv] + + +open GroupoidModel.FunctorOperation.pi Functor in /-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ 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) := - have := isSplit_strictifyClovenIsofibration hF hG calc (σ ⟶ pushforward hF hG) - _ ≃ {f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ - ∫ (strictifyClovenIsofibration hF hG).classifier // - (f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom)} := - pushforwardHomEquivAux1 .. - _ ≃ ((Over.pullback F).obj σ ⟶ Over.mk G) := sorry --pushforwardHomEquivAux2 .. - + _ ≃ {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 + sorry) + invFun N := ⟨(grothendieckIsoPullback hF σ).hom ⋙ N.left, sorry⟩ + left_inv := sorry + right_inv := sorry } /-- Naturality in the universal property of the pushforward. -/ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} @@ -247,7 +187,6 @@ lemma pushforwardHomEquiv_comp {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) (Over.pullback F).map f ≫ (pushforwardHomEquiv hF hG X') g := by sorry - 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 .. @@ -295,14 +234,14 @@ instance SplitIsofibration.RespectsIso : SplitIsofibration.RespectsIso := inferI instance : SplitIsofibration.IsStableUnderPushforward SplitIsofibration where of_isPushforward F G P := by intro h - have p: (Over.mk P) ≅ Grpd.pushforward (F.snd) (G.snd) := + 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 [ee] simp only[e] apply (SplitIsofibration.RespectsIso).precomp assumption From c65855e6f662b19e4333a87cb871ddb661ce3924 Mon Sep 17 00:00:00 2001 From: jlh18 Date: Thu, 23 Oct 2025 17:00:24 -0400 Subject: [PATCH 58/59] chore: remove comments --- .../CategoryTheory/SplitIsofibration.lean | 50 ------------------- HoTTLean/Groupoids/SplitIsofibration.lean | 35 ------------- 2 files changed, 85 deletions(-) diff --git a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean index 96e41587..79d205eb 100644 --- a/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean +++ b/HoTTLean/ForMathlib/CategoryTheory/SplitIsofibration.lean @@ -677,56 +677,6 @@ in the HoTTLean groupoid model. -/ abbrev pushforward := ∫ GroupoidModel.FunctorOperation.pi (IF.classifier) (pushforward.strictifyClovenIsofibration IF IG).classifier --- /-- The morphism part (a functor) of the pushforward along `F`, of `G`. --- This is defined as the forgetful functor from the Grothendieck construction. -/ --- abbrev pushforwardHom : pushforwardLeft IF IG ⥤ A := --- Functor.Groupoidal.forget - --- /-- The pushforward along `F`, of `G`, as an object in the over category. -/ --- abbrev pushforward : 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 pullbackIsoGrothendieck {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 σ) - - /-- `∫ σ.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. -/ diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean index af6cb28f..bfb205b7 100644 --- a/HoTTLean/Groupoids/SplitIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -59,19 +59,6 @@ section open Functor.ClovenIsofibration --- def strictify {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) (G : C ⟶ B) : --- C ⟶ Grpd.of (∫ classifier (hF.splitIsofibration)) := --- G ≫ hF.grothendieckClassifierIso.inv - --- def strictifyClovenIsofibration {C B A : Grpd} {F : B ⟶ A} (hF : SplitIsofibration F) --- {G : C ⟶ B} (hG : SplitIsofibration G) : (strictify hF G).ClovenIsofibration := --- sorry - --- lemma isSplit_strictifyClovenIsofibration {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) --- {G : C ⟶ B} (hG : SplitIsofibration G) : --- (strictifyClovenIsofibration hF hG).IsSplit := --- sorry - /-- 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. -/ @@ -136,28 +123,6 @@ lemma grothendieckIsoPullback_comp_forget {B A} {F : B ⟶ A} (hF : SplitIsofibr exact (pre_classifier_isPullback hF σ).isoIsPullback_inv_snd _ _ (pullback_isPullback hF σ) --- open GroupoidModel.FunctorOperation.pi in --- /-- `∫ σ.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. -/ --- def pushforwardHomEquivAux1 {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} --- (hG : SplitIsofibration G) (σ : Over A) : --- have := isSplit_strictifyClovenIsofibration hF hG --- (σ ⟶ pushforward hF hG) ≃ --- {f : ∫ σ.hom ⋙ hF.splitIsofibration.classifier ⥤ --- ∫ (strictifyClovenIsofibration hF hG).classifier // --- f ⋙ Functor.Groupoidal.forget = pre hF.splitIsofibration.classifier σ.hom } where --- toFun f := ⟨equivFun _ f.left f.w, equivFun_comp_forget ..⟩ --- invFun f := Over.homMk (equivInv _ f.1 f.2) --- (equivInv_comp_forget ..) --- left_inv f := by --- ext --- simp [equivInv_equivFun] --- right_inv f := by --- ext --- simp [equivFun_equivInv] - - open GroupoidModel.FunctorOperation.pi Functor in /-- The universal property of the pushforward, expressed as a (natural) bijection of hom sets. -/ def pushforwardHomEquiv {C B A} {F : B ⟶ A} (hF : SplitIsofibration F) {G : C ⟶ B} From 8e34d995fb5710c741b05fb7c89fc176b22b2986 Mon Sep 17 00:00:00 2001 From: Yiming Xu Date: Sat, 25 Oct 2025 21:12:26 -0400 Subject: [PATCH 59/59] fix: Grpd.splitIsofibration_pushforward --- HoTTLean/Groupoids/SplitIsofibration.lean | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/HoTTLean/Groupoids/SplitIsofibration.lean b/HoTTLean/Groupoids/SplitIsofibration.lean index bfb205b7..5ff83cb6 100644 --- a/HoTTLean/Groupoids/SplitIsofibration.lean +++ b/HoTTLean/Groupoids/SplitIsofibration.lean @@ -27,9 +27,13 @@ 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 := - sorry + hF.grothendieckClassifierIso.inv ⋙ homOf Functor.Groupoidal.forget = F := by + apply Functor.ClovenIsofibration.grothendieckClassifierIso.inv_comp_forget + end SplitIsofibration @@ -177,8 +181,15 @@ def isoPushforwardOfIsPushforward {B A} {F : B ⟶ A} (hF : SplitIsofibration F -- 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) := - sorry + 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`