Skip to content

Commit

Permalink
Merge pull request #347 from agda/BaseChange
Browse files Browse the repository at this point in the history
Cleaning up Slice Functor and surrounding infrastructure
  • Loading branch information
JacquesCarette authored Dec 30, 2023
2 parents 85ecdcf + fce3d00 commit e5fef74
Show file tree
Hide file tree
Showing 5 changed files with 117 additions and 90 deletions.
21 changes: 21 additions & 0 deletions src/Categories/Adjoint/Instance/BaseChange.agda
Original file line number Diff line number Diff line change
@@ -0,0 +1,21 @@
{-# OPTIONS --without-K --safe #-}

open import Categories.Category using (Category)

module Categories.Adjoint.Instance.BaseChange {o ℓ e} (C : Category o ℓ e) where

open import Categories.Adjoint using (_⊣_)
open import Categories.Adjoint.Compose using (_∘⊣_)
open import Categories.Adjoint.Instance.Slice using (Forgetful⊣Free)
open import Categories.Category.Slice C using (Slice)
open import Categories.Category.Slice.Properties C using (pullback⇒product; slice-slice≃slice)
open import Categories.Category.Equivalence.Properties using (module C≅D)
open import Categories.Diagram.Pullback C using (Pullback)
open import Categories.Functor.Slice.BaseChange C using (BaseChange!; BaseChange*)

open Category C

module _ {A B : Obj} (f : B ⇒ A) (pullback : {C} {h : C ⇒ A} Pullback f h) where

!⊣* : BaseChange! f ⊣ BaseChange* f pullback
!⊣* = C≅D.L⊣R (slice-slice≃slice f) ∘⊣ Forgetful⊣Free (Slice A) (pullback⇒product pullback)
46 changes: 46 additions & 0 deletions src/Categories/Adjoint/Instance/Slice.agda
Original file line number Diff line number Diff line change
@@ -0,0 +1,46 @@
{-# OPTIONS --safe --without-K #-}

open import Categories.Category using (Category)

module Categories.Adjoint.Instance.Slice {o ℓ e} (C : Category o ℓ e) where

open import Categories.Adjoint using (_⊣_)
open import Categories.Category.Slice C using (SliceObj; Slice⇒; slicearr)
open import Categories.Functor.Slice C using (Forgetful; Free)
open import Categories.NaturalTransformation using (ntHelper)
open import Categories.Object.Product C

open Category C
open HomReasoning

open SliceObj
open Slice⇒

module _ {A : Obj} (product : {X} Product A X) where

private
module product {X} = Product (product {X})
open product

Forgetful⊣Free : Forgetful ⊣ Free product
Forgetful⊣Free = record
{ unit = ntHelper record
{ η = λ _ slicearr project₁
; commute = λ {X} {Y} f begin
⟨ arr Y , id ⟩ ∘ h f ≈⟨ ∘-distribʳ-⟨⟩ ⟩
⟨ arr Y ∘ h f , id ∘ h f ⟩ ≈⟨ ⟨⟩-cong₂ (△ f) identityˡ ⟩
⟨ arr X , h f ⟩ ≈˘⟨ ⟨⟩-cong₂ identityˡ identityʳ ⟩
⟨ id ∘ arr X , h f ∘ id ⟩ ≈˘⟨ [ product ⇒ product ]×∘⟨⟩ ⟩
[ product ⇒ product ] id × h f ∘ ⟨ arr X , id ⟩ ∎
}
; counit = ntHelper record
{ η = λ _ π₂
; commute = λ _ project₂
}
; zig = project₂
; zag = begin
[ product ⇒ product ]id× π₂ ∘ ⟨ π₁ , id ⟩ ≈⟨ [ product ⇒ product ]×∘⟨⟩ ⟩
⟨ id ∘ π₁ , π₂ ∘ id ⟩ ≈⟨ ⟨⟩-cong₂ identityˡ identityʳ ⟩
⟨ π₁ , π₂ ⟩ ≈⟨ η ⟩
id ∎
}
6 changes: 3 additions & 3 deletions src/Categories/Category/Construction/Comma.agda
Original file line number Diff line number Diff line change
Expand Up @@ -43,7 +43,7 @@ module _ {A : Category o₁ ℓ₁ e₁} {B : Category o₂ ℓ₂ e₂} {C : C
h : B [ β₁ , β₂ ]
commute : CommutativeSquare f₁ (T₁ g) (S₁ h) f₂

Comma : Functor A C Functor B C Category _ _ _
Comma : Functor A C Functor B C Category (o₁ ⊔ o₂ ⊔ ℓ₃) (ℓ₁ ⊔ ℓ₂ ⊔ e₃) (e₁ ⊔ e₂)
Comma T S = record
{ Obj = CommaObj T S
; _⇒_ = Comma⇒
Expand Down Expand Up @@ -132,8 +132,8 @@ module _ {C : Category o₁ ℓ₁ e₁} {D : Category o₂ ℓ₂ e₂} where
module C = Category C

infix 4 _↙_ _↘_
_↙_ : (X : C.Obj) (T : Functor D C) Category _ _ _
_↙_ : (X : C.Obj) (T : Functor D C) Category (o₂ ⊔ ℓ₁) (ℓ₂ ⊔ e₁) e₂
X ↙ T = const! X ↓ T

_↘_ : (S : Functor D C) (X : C.Obj) Category _ _ _
_↘_ : (S : Functor D C) (X : C.Obj) Category (o₂ ⊔ ℓ₁) (ℓ₂ ⊔ e₁) e₂
S ↘ X = S ↓ const! X
110 changes: 23 additions & 87 deletions src/Categories/Functor/Slice.agda
Original file line number Diff line number Diff line change
@@ -1,22 +1,18 @@
{-# OPTIONS --without-K --safe #-}

open import Categories.Category
open import Categories.Category using (Category)

module Categories.Functor.Slice {o ℓ e} (C : Category o ℓ e) where

open import Data.Product using (_,_)
open import Function using () renaming (id to id→)

open import Categories.Adjoint
open import Categories.Category.CartesianClosed
open import Categories.Category.CartesianClosed.Locally
open import Categories.Functor hiding (id)
open import Categories.Functor.Properties
open import Categories.Diagram.Pullback C using (Pullback; unglue; Pullback-resp-≈)
open import Categories.Functor using (Functor)
open import Categories.Functor.Properties using ([_]-resp-∘)
open import Categories.Morphism.Reasoning C
open import Categories.NaturalTransformation hiding (id)
open import Categories.Object.Product C

import Categories.Category.Slice as S
import Categories.Diagram.Pullback as P
import Categories.Category.Construction.Pullbacks as Pbs

open Category C
Expand All @@ -27,74 +23,32 @@ module _ {A : Obj} where
open S.SliceObj
open S.Slice⇒

-- A functor between categories induces one between the corresponding slices at a given object of C.
Base-F : {o′ ℓ′ e′} {D : Category o′ ℓ′ e′} (F : Functor C D) Functor (S.Slice C A) (S.Slice D (Functor.F₀ F A))
Base-F {D = D} F = record
{ F₀ = λ { (S.sliceobj arr) S.sliceobj (F₁ arr) }
; F₁ = λ { (S.slicearr △) S.slicearr ([ F ]-resp-∘ △) }
Base-F F = record
{ F₀ = λ s S.sliceobj (F₁ (arr s))
; F₁ = λ s⇒ S.slicearr ([ F ]-resp-∘ (△ s⇒))
; identity = identity
; homomorphism = homomorphism
; F-resp-≈ = F-resp-≈
}
where module D = Category D
open Functor F
where open Functor F

open S C

Forgetful : Functor (Slice A) C
Forgetful = record
{ F₀ = λ X Y X
; F₁ = λ f h f
{ F₀ = Y
; F₁ = h
; identity = refl
; homomorphism = refl
; F-resp-≈ = λ eq eq
; F-resp-≈ = id→
}

BaseChange! : {B} (f : B ⇒ A) Functor (Slice B) (Slice A)
BaseChange! f = record
{ F₀ = λ X sliceobj (f ∘ arr X)
; F₁ = λ g slicearr (pullʳ (△ g))
; identity = refl
; homomorphism = refl
; F-resp-≈ = λ eq eq
}


module _ (pullbacks : {X Y Z} (h : X ⇒ Z) (i : Y ⇒ Z) P.Pullback C h i) where
module _ (pullback : {X} {Y} {Z} (h : X ⇒ Z) (i : Y ⇒ Z) Pullback h i) where
private
open P C
module pullbacks {X Y Z} h i = Pullback (pullbacks {X} {Y} {Z} h i)
open pullbacks

BaseChange* : {B} (f : B ⇒ A) Functor (Slice A) (Slice B)
BaseChange* f = record
{ F₀ = λ X sliceobj (p₂ (arr X) f)
; F₁ = λ {X Y} g slicearr {h = Pullback.p₂ (unglue (pullbacks (arr Y) f)
(Pullback-resp-≈ (pullbacks (arr X) f) (△ g) refl))}
(p₂∘universal≈h₂ (arr Y) f)
; identity = λ {X} ⟺ (unique (arr X) f id-comm identityʳ)
; homomorphism = λ {X Y Z} {h i} unique-diagram (arr Z) f (p₁∘universal≈h₁ (arr Z) f ○ assoc ○ ⟺ (pullʳ (p₁∘universal≈h₁ (arr Y) f)) ○ ⟺ (pullˡ (p₁∘universal≈h₁ (arr Z) f)))
(p₂∘universal≈h₂ (arr Z) f ○ ⟺ (p₂∘universal≈h₂ (arr Y) f) ○ ⟺ (pullˡ (p₂∘universal≈h₂ (arr Z) f)))
; F-resp-≈ = λ {X Y} eq″ unique (arr Y) f (p₁∘universal≈h₁ (arr Y) f ○ ∘-resp-≈ˡ eq″) (p₂∘universal≈h₂ (arr Y) f)
}


!⊣* : {B} (f : B ⇒ A) BaseChange! f ⊣ BaseChange* f
!⊣* f = record
{ unit = ntHelper record
{ η = λ X slicearr (p₂∘universal≈h₂ (f ∘ arr X) f {eq = identityʳ})
; commute = λ {X Y} g unique-diagram (f ∘ arr Y) f
(cancelˡ (p₁∘universal≈h₁ (f ∘ arr Y) f) ○ ⟺ (cancelʳ (p₁∘universal≈h₁ (f ∘ arr X) f)) ○ pushˡ (⟺ (p₁∘universal≈h₁ (f ∘ arr Y) f)))
(pullˡ (p₂∘universal≈h₂ (f ∘ arr Y) f) ○ △ g ○ ⟺ (p₂∘universal≈h₂ (f ∘ arr X) f) ○ pushˡ (⟺ (p₂∘universal≈h₂ (f ∘ arr Y) f)))
}
; counit = ntHelper record
{ η = λ X slicearr (pullbacks.commute (arr X) f)
; commute = λ {X Y} g p₁∘universal≈h₁ (arr Y) f
}
; zig = λ {X} p₁∘universal≈h₁ (f ∘ arr X) f
; zag = λ {Y} unique-diagram (arr Y) f
(pullˡ (p₁∘universal≈h₁ (arr Y) f) ○ pullʳ (p₁∘universal≈h₁ (f ∘ pullbacks.p₂ (arr Y) f) f))
(pullˡ (p₂∘universal≈h₂ (arr Y) f) ○ p₂∘universal≈h₂ (f ∘ pullbacks.p₂ (arr Y) f) f ○ ⟺ identityʳ)
}
module pullbacks {X Y Z} h i = Pullback (pullback {X} {Y} {Z} h i)
open pullbacks using (p₂; p₂∘universal≈h₂; unique; unique-diagram; p₁∘universal≈h₁)

pullback-functorial : {B} (f : B ⇒ A) Functor (Slice A) C
pullback-functorial f = record
Expand All @@ -109,7 +63,7 @@ module _ {A : Obj} where
(p.p₂∘universal≈h₂ B ○ ∘-resp-≈ˡ eq ○ ⟺ (p.p₂∘universal≈h₂ B))
}
where p : X Pullback f (arr X)
p X = pullbacks f (arr X)
p X = pullback f (arr X)
module p X = Pullback (p X)

p⇒ : X Y (g : Slice⇒ X Y) p.P X ⇒ p.P Y
Expand All @@ -128,35 +82,17 @@ module _ {A : Obj} where

module _ (product : {X : Obj} Product A X) where

private
module product {X} = Product (product {X})
open product

-- this is adapted from proposition 1.33 of Aspects of Topoi (Freyd, 1972)
Free : Functor C (Slice A)
Free = record
{ F₀ = λ _ sliceobj [ product ]π₁
{ F₀ = λ _ sliceobj π₁
; F₁ = λ f slicearr ([ product ⇒ product ]π₁∘× ○ identityˡ)
; identity = id×id product
; homomorphism = sym [ product ⇒ product ⇒ product ]id×∘id×
; F-resp-≈ = λ f≈g Product.⟨⟩-cong₂ product refl (∘-resp-≈ˡ f≈g)
; F-resp-≈ = λ f≈g ⟨⟩-cong₂ refl (∘-resp-≈ˡ f≈g)
}

Forgetful⊣Free : Forgetful ⊣ Free
Forgetful⊣Free = record
{ unit = ntHelper record
{ η = λ _ slicearr (Product.project₁ product)
; commute = λ {X} {Y} f begin
[ product ]⟨ arr Y , id ⟩ ∘ h f ≈⟨ [ product ]⟨⟩∘ ⟩
[ product ]⟨ arr Y ∘ h f , id ∘ h f ⟩ ≈⟨ Product.⟨⟩-cong₂ product (△ f) identityˡ ⟩
[ product ]⟨ arr X , h f ⟩ ≈˘⟨ Product.⟨⟩-cong₂ product identityˡ identityʳ ⟩
[ product ]⟨ id ∘ arr X , h f ∘ id ⟩ ≈˘⟨ [ product ⇒ product ]×∘⟨⟩ ⟩
[ product ⇒ product ] id × h f ∘ [ product ]⟨ arr X , id ⟩ ∎
}
; counit = ntHelper record
{ η = λ _ Product.π₂ product
; commute = λ _ Product.project₂ product
}
; zig = Product.project₂ product
; zag = begin
[ product ⇒ product ]id× [ product ]π₂ ∘ [ product ]⟨ [ product ]π₁ , id ⟩ ≈⟨ [ product ⇒ product ]×∘⟨⟩ ⟩
[ product ]⟨ id ∘ [ product ]π₁ , [ product ]π₂ ∘ id ⟩ ≈⟨ Product.⟨⟩-cong₂ product identityˡ identityʳ ⟩
[ product ]⟨ [ product ]π₁ , [ product ]π₂ ⟩ ≈⟨ Product.η product ⟩
id ∎
}
24 changes: 24 additions & 0 deletions src/Categories/Functor/Slice/BaseChange.agda
Original file line number Diff line number Diff line change
@@ -0,0 +1,24 @@
{-# OPTIONS --without-K --safe #-}

open import Categories.Category using (Category)

module Categories.Functor.Slice.BaseChange {o ℓ e} (C : Category o ℓ e) where

open import Categories.Category.Slice C using (Slice)
open import Categories.Category.Slice.Properties C using (pullback⇒product; slice-slice⇒slice; slice⇒slice-slice)
open import Categories.Functor using (Functor; _∘F_)
open import Categories.Functor.Slice using (Forgetful; Free)
open import Categories.Diagram.Pullback C using (Pullback)

open Category C

module _ {A B : Obj} (f : B ⇒ A) where

-- Any morphism induces a functor between slices.
BaseChange! : Functor (Slice B) (Slice A)
BaseChange! = Forgetful (Slice A) ∘F slice⇒slice-slice f

-- Any morphism which admits pullbacks induces a functor the other way between slices.
-- This is adjoint to BaseChange!: see Categories.Adjoint.Instance.BaseChange.
BaseChange* : ( {C} {h : C ⇒ A} Pullback f h) Functor (Slice A) (Slice B)
BaseChange* pullback = slice-slice⇒slice f ∘F Free (Slice A) (pullback⇒product pullback)

0 comments on commit e5fef74

Please sign in to comment.