-
Notifications
You must be signed in to change notification settings - Fork 74
Right adjoint to Functor.Slice.Free #408
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
base: master
Are you sure you want to change the base?
Changes from 2 commits
44363cc
56f4a35
5559e74
0322606
11dddb7
bf07868
723fe77
ce4a518
e25ea8a
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -5,10 +5,18 @@ 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.Category.BinaryProducts C | ||
| open import Categories.Category.Cartesian using (Cartesian) | ||
| open import Categories.Category.CartesianClosed using (CartesianClosed) | ||
| open import Categories.Category.Slice C using (SliceObj; sliceobj; Slice⇒; slicearr) | ||
| open import Categories.Functor.Slice C using (Forgetful; Free; Coforgetful) | ||
| open import Categories.Morphism.Reasoning C | ||
| open import Categories.NaturalTransformation using (ntHelper) | ||
| open import Categories.Diagram.Pullback C hiding (swap) | ||
| open import Categories.Object.Product C | ||
| open import Categories.Object.Terminal C | ||
|
|
||
| open import Function.Base using (_$_) | ||
|
|
||
| open Category C | ||
| open HomReasoning | ||
|
|
@@ -44,3 +52,94 @@ module _ {A : Obj} (product : ∀ {X} → Product A X) where | |
| ⟨ π₁ , π₂ ⟩ ≈⟨ η ⟩ | ||
| id ∎ | ||
| } | ||
|
|
||
| module _ {A : Obj} (ccc : CartesianClosed C) (pullback : ∀ {X} {Y} {Z} (h : X ⇒ Z) (i : Y ⇒ Z) → Pullback h i) where | ||
|
|
||
| open CartesianClosed ccc | ||
| open Cartesian cartesian | ||
| open Terminal terminal | ||
| open BinaryProducts products | ||
|
|
||
| Free⊣Coforgetful : Free {A = A} product ⊣ Coforgetful ccc pullback | ||
| Free⊣Coforgetful = record | ||
| { unit = ntHelper record | ||
| { η = λ X → p.universal (sliceobj π₁) (λ-unique₂′ (unit-pb X)) | ||
| ; commute = λ {S} {T} f → p.unique-diagram (sliceobj π₁) !-unique₂ $ begin | ||
| p.p₂ (sliceobj π₁) ∘ p.universal (sliceobj π₁) _ ∘ f ≈⟨ pullˡ (p.p₂∘universal≈h₂ (sliceobj π₁)) ⟩ | ||
| λg swap ∘ f ≈⟨ subst ⟩ | ||
| λg (swap ∘ first f) ≈⟨ λ-cong swap∘⁂ ⟩ | ||
| λg (second f ∘ swap) ≈˘⟨ λ-cong (∘-resp-≈ʳ β′) ⟩ | ||
| λg (second f ∘ eval′ ∘ first (λg swap)) ≈˘⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ (⁂-cong₂ (p.p₂∘universal≈h₂ (sliceobj π₁)) Equiv.refl))) ⟩ | ||
| λg (second f ∘ eval′ ∘ first (p.p₂ (sliceobj π₁) ∘ p.universal (sliceobj π₁) _)) ≈˘⟨ λ-cong (pull-last first∘first) ⟩ | ||
| λg ((second f ∘ eval′ ∘ first (p.p₂ (sliceobj π₁))) ∘ first (p.universal (sliceobj π₁) _)) ≈˘⟨ subst ⟩ | ||
| λg (second f ∘ eval′ ∘ first (p.p₂ (sliceobj π₁))) ∘ p.universal (sliceobj π₁) _ ≈˘⟨ pullˡ (p.p₂∘universal≈h₂ (sliceobj π₁)) ⟩ | ||
| p.p₂ (sliceobj π₁) ∘ p.universal (sliceobj π₁) _ ∘ p.universal (sliceobj π₁) _ ∎ | ||
| } | ||
| ; counit = ntHelper record | ||
| { η = λ X → slicearr (counit-△ X) | ||
| ; commute = λ {S} {T} f → begin | ||
| (eval′ ∘ first (p.p₂ T) ∘ swap) ∘ second (p.universal T _) ≈⟨ pull-last swap∘⁂ ⟩ | ||
| eval′ ∘ first (p.p₂ T) ∘ first (p.universal T _) ∘ swap ≈⟨ refl⟩∘⟨ pullˡ first∘first ⟩ | ||
| eval′ ∘ first (p.p₂ T ∘ p.universal T _) ∘ swap ≈⟨ refl⟩∘⟨ ⁂-cong₂ (p.p₂∘universal≈h₂ T) Equiv.refl ⟩∘⟨refl ⟩ | ||
| eval′ ∘ first (λg (h f ∘ eval′ ∘ first (p.p₂ S))) ∘ swap ≈⟨ pullˡ β′ ⟩ | ||
| (h f ∘ eval′ ∘ first (p.p₂ S)) ∘ swap ≈⟨ assoc²' ⟩ | ||
| h f ∘ eval′ ∘ first (p.p₂ S) ∘ swap ∎ | ||
| } | ||
| ; zig = λ {X} → begin | ||
| (eval′ ∘ first (p.p₂ (sliceobj π₁)) ∘ swap) ∘ second (p.universal (sliceobj π₁) _) ≈⟨ assoc²' ⟩ | ||
| eval′ ∘ first (p.p₂ (sliceobj π₁)) ∘ swap ∘ second (p.universal (sliceobj π₁) _) ≈⟨ refl⟩∘⟨ refl⟩∘⟨ swap∘⁂ ⟩ | ||
| eval′ ∘ first (p.p₂ (sliceobj π₁)) ∘ first (p.universal (sliceobj π₁) _) ∘ swap ≈⟨ refl⟩∘⟨ pullˡ first∘first ⟩ | ||
| eval′ ∘ first (p.p₂ (sliceobj π₁) ∘ p.universal (sliceobj π₁) _) ∘ swap ≈⟨ refl⟩∘⟨ ⁂-cong₂ (p.p₂∘universal≈h₂ (sliceobj π₁)) Equiv.refl ⟩∘⟨refl ⟩ | ||
| eval′ ∘ first (λg swap) ∘ swap ≈⟨ pullˡ β′ ⟩ | ||
| swap ∘ swap ≈⟨ swap∘swap ⟩ | ||
| id ∎ | ||
| ; zag = λ {X} → p.unique-diagram X !-unique₂ $ begin | ||
| p.p₂ X ∘ p.universal X _ ∘ p.universal (sliceobj π₁) _ ≈⟨ pullˡ (p.p₂∘universal≈h₂ X) ⟩ | ||
| λg ((eval′ ∘ first (p.p₂ X) ∘ swap) ∘ eval′ ∘ first (p.p₂ (sliceobj π₁))) ∘ p.universal (sliceobj π₁) _ ≈˘⟨ pullˡ (subst ○ λ-cong assoc) ⟩ | ||
| λg ((eval′ ∘ first (p.p₂ X) ∘ swap) ∘ eval′) ∘ p.p₂ (sliceobj π₁) ∘ p.universal (sliceobj π₁) _ ≈⟨ refl⟩∘⟨ p.p₂∘universal≈h₂ (sliceobj π₁) ⟩ | ||
| λg ((eval′ ∘ first (p.p₂ X) ∘ swap) ∘ eval′) ∘ λg swap ≈⟨ subst ⟩ | ||
| λg (((eval′ ∘ first (p.p₂ X) ∘ swap) ∘ eval′) ∘ first (λg swap)) ≈⟨ λ-cong (pullʳ β′) ⟩ | ||
| λg ((eval′ ∘ first (p.p₂ X) ∘ swap) ∘ swap) ≈⟨ λ-cong (pull-last swap∘swap) ⟩ | ||
|
||
| λg (eval′ ∘ first (p.p₂ X) ∘ id) ≈⟨ λ-cong (∘-resp-≈ʳ identityʳ) ⟩ | ||
| λg (eval′ ∘ first (p.p₂ X)) ≈⟨ η-exp′ ⟩ | ||
| p.p₂ X ≈˘⟨ identityʳ ⟩ | ||
| p.p₂ X ∘ id ∎ | ||
| } | ||
| where | ||
| p : (X : SliceObj A) → Pullback {X = ⊤} {Z = A ^ A} {Y = Y X ^ A} (λg π₂) (λg (arr X ∘ eval′)) | ||
| p X = pullback (λg π₂) (λg (arr X ∘ eval′)) | ||
| module p X = Pullback (p X) | ||
|
|
||
| abstract | ||
| unit-pb : ∀ (X : Obj) → eval′ ∘ first {A = X} {C = A} (λg π₂ ∘ !) ≈ eval′ ∘ first (λg (π₁ ∘ eval′) ∘ λg swap) | ||
| unit-pb X = begin | ||
| eval′ ∘ first (λg π₂ ∘ !) ≈˘⟨ refl⟩∘⟨ first∘first ⟩ | ||
| eval′ ∘ first (λg π₂) ∘ first ! ≈⟨ pullˡ β′ ⟩ | ||
| π₂ ∘ first ! ≈⟨ π₂∘⁂ ○ identityˡ ⟩ | ||
| π₂ ≈˘⟨ project₁ ⟩ | ||
| π₁ ∘ swap ≈˘⟨ refl⟩∘⟨ β′ ⟩ | ||
| π₁ ∘ eval′ ∘ first (λg swap) ≈˘⟨ extendʳ β′ ⟩ | ||
| eval′ ∘ first (λg (π₁ ∘ eval′)) ∘ first (λg swap) ≈⟨ refl⟩∘⟨ first∘first ⟩ | ||
| eval′ ∘ first (λg (π₁ ∘ eval′) ∘ λg swap) ∎ | ||
| -- A good chunk of the above, maybe all if you squint, is duplicated with F₁-lemma | ||
| -- eval′ ∘ first (λg π₂ ∘ !) ≈ eval′ ∘ first (λg (f ∘ eval′) ∘ first (λg g) | ||
| -- With f : X ⇒ Y and g : Z × Y ⇒ X. Not sure what conditions f and g need to have | ||
|
|
||
| -- Would it be better if Free used π₂ rather than π₁? | ||
| -- It would mean we could avoid this swap | ||
| counit-△ : ∀ X → arr X ∘ eval′ ∘ first (p.p₂ X) ∘ swap ≈ π₁ | ||
| counit-△ X = begin | ||
| arr X ∘ eval′ ∘ first (p.p₂ X) ∘ swap ≈˘⟨ assoc² ⟩ | ||
| ((arr X ∘ eval′) ∘ first (p.p₂ X)) ∘ swap ≈⟨ lemma ⟩∘⟨refl ⟩ | ||
| (π₂ ∘ first (p.p₁ X)) ∘ swap ≈⟨ (π₂∘⁂ ○ identityˡ) ⟩∘⟨refl ⟩ | ||
| π₂ ∘ swap ≈⟨ project₂ ⟩ | ||
| π₁ ∎ | ||
| where | ||
| lemma : (arr X ∘ eval′) ∘ first (p.p₂ X) ≈ π₂ ∘ first (p.p₁ X) | ||
| lemma = λ-inj $ begin | ||
| λg ((arr X ∘ eval′) ∘ first (p.p₂ X)) ≈˘⟨ subst ⟩ | ||
| λg (arr X ∘ eval′) ∘ p.p₂ X ≈˘⟨ p.commute X ⟩ | ||
| λg π₂ ∘ p.p₁ X ≈⟨ subst ⟩ | ||
| λg (π₂ ∘ first (p.p₁ X)) ∎ | ||
|
|
||
|
|
||
| Original file line number | Diff line number | Diff line change |
|---|---|---|
|
|
@@ -4,16 +4,22 @@ open import Categories.Category using (Category) | |
|
|
||
| module Categories.Functor.Slice {o ℓ e} (C : Category o ℓ e) where | ||
|
|
||
| open import Function using () renaming (id to id→) | ||
| open import Function.Base using (_$_) renaming (id to id→) | ||
|
|
||
| open import Categories.Category.BinaryProducts | ||
| open import Categories.Category.Cartesian | ||
| open import Categories.Category.CartesianClosed C | ||
| 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.Object.Exponential C | ||
| open import Categories.Object.Product C | ||
| open import Categories.Object.Terminal C | ||
|
|
||
| import Categories.Category.Slice as S | ||
| import Categories.Category.Construction.Pullbacks as Pbs | ||
| import Categories.Object.Product.Construction as ×C | ||
|
|
||
| open Category C | ||
| open HomReasoning | ||
|
|
@@ -96,3 +102,58 @@ module _ {A : Obj} where | |
| ; F-resp-≈ = λ f≈g → ⟨⟩-cong₂ refl (∘-resp-≈ˡ f≈g) | ||
| } | ||
|
|
||
| -- This can and probably should be restricted | ||
| -- e.g. we only need exponential objects with A as domain | ||
| -- I don't think we need all products but I don't have a clear idea of what products we do need | ||
| module _ (ccc : CartesianClosed) (pullback : ∀ {X} {Y} {Z} (h : X ⇒ Z) (i : Y ⇒ Z) → Pullback h i) where | ||
|
|
||
| open CartesianClosed ccc | ||
| open Cartesian cartesian | ||
| open Terminal terminal | ||
| open BinaryProducts products | ||
|
|
||
| -- Needs better name! | ||
|
||
| Coforgetful : Functor (Slice A) C | ||
| Coforgetful = record | ||
| { F₀ = p.P | ||
| ; F₁ = λ f → p.universal _ (F₁-lemma f) | ||
| ; identity = λ {X} → sym $ p.unique X (sym (!-unique _)) $ begin | ||
| p.p₂ X ∘ id ≈⟨ identityʳ ⟩ | ||
| p.p₂ X ≈˘⟨ η-exp′ ⟩ | ||
| λg (eval′ ∘ first (p.p₂ X)) ≈˘⟨ λ-cong (pullˡ identityˡ) ⟩ | ||
| λg (id ∘ eval′ ∘ first (p.p₂ X)) ∎ | ||
| ; homomorphism = λ {S} {T} {U} {f} {g} → sym $ p.unique U (sym (!-unique _)) $ begin | ||
| p.p₂ U ∘ p.universal U (F₁-lemma g) ∘ p.universal T (F₁-lemma f) ≈⟨ pullˡ (p.p₂∘universal≈h₂ U) ⟩ | ||
| λg (h g ∘ eval′ ∘ first (p.p₂ T)) ∘ p.universal T (F₁-lemma f) ≈˘⟨ pullˡ (subst ○ λ-cong assoc) ⟩ | ||
| λg (h g ∘ eval′) ∘ p.p₂ T ∘ p.universal T (F₁-lemma f) ≈⟨ refl⟩∘⟨ p.p₂∘universal≈h₂ T ⟩ | ||
| λg (h g ∘ eval′) ∘ λg (h f ∘ eval′ ∘ first (p.p₂ S)) ≈⟨ subst ⟩ | ||
| λg ((h g ∘ eval′) ∘ first (λg (h f ∘ eval′ ∘ first (p.p₂ S)))) ≈⟨ λ-cong (pullʳ β′) ⟩ | ||
| λg (h g ∘ (h f ∘ eval′ ∘ first (p.p₂ S))) ≈⟨ λ-cong sym-assoc ⟩ | ||
| λg ((h g ∘ h f) ∘ eval′ ∘ first (p.p₂ S)) ∎ | ||
| ; F-resp-≈ = λ f≈g → p.universal-resp-≈ _ refl (λ-cong (∘-resp-≈ˡ f≈g)) | ||
| } | ||
| where | ||
| p : (X : SliceObj A) → Pullback {X = ⊤} {Z = A ^ A} {Y = Y X ^ A} (λg π₂) (λg (arr X ∘ eval′)) | ||
| p X = pullback (λg π₂) (λg (arr X ∘ eval′)) | ||
| module p X = Pullback (p X) | ||
|
|
||
| abstract | ||
| F₁-lemma : ∀ {S} {T} (f : Slice⇒ S T) → λg π₂ ∘ ! ≈ λg (arr T ∘ eval′) ∘ λg (h f ∘ eval′ ∘ first (p.p₂ S)) | ||
| F₁-lemma {S} {T} f = λ-unique₂′ $ begin | ||
| eval′ ∘ first (λg π₂ ∘ !) ≈˘⟨ refl⟩∘⟨ first∘first ⟩ | ||
| eval′ ∘ first (λg π₂) ∘ first ! ≈⟨ pullˡ β′ ⟩ | ||
| π₂ ∘ first ! ≈⟨ π₂∘⁂ ○ identityˡ ⟩ | ||
| π₂ ≈⟨ λ-inj lemma ⟩ | ||
| arr S ∘ eval′ ∘ first (p.p₂ S) ≈˘⟨ pullˡ (△ f) ⟩ | ||
| arr T ∘ h f ∘ eval′ ∘ first (p.p₂ S) ≈˘⟨ pullʳ β′ ⟩ | ||
| (arr T ∘ eval′) ∘ first (λg (h f ∘ eval′ ∘ first (p.p₂ S))) ≈˘⟨ pullˡ β′ ⟩ | ||
| eval′ ∘ first (λg (arr T ∘ eval′)) ∘ first (λg (h f ∘ eval′ ∘ first (p.p₂ S))) ≈⟨ refl⟩∘⟨ first∘first ⟩ | ||
| eval′ ∘ first (λg (arr T ∘ eval′) ∘ λg (h f ∘ eval′ ∘ first (p.p₂ S))) ∎ | ||
| where | ||
| lemma : λg π₂ ≈ λg (arr S ∘ eval′ ∘ first (p.p₂ S)) | ||
| lemma = begin | ||
| λg π₂ ≈˘⟨ λ-cong (π₂∘⁂ ○ identityˡ) ⟩ | ||
| λg (π₂ ∘ first (p.p₁ S)) ≈˘⟨ subst ⟩ | ||
| λg π₂ ∘ p.p₁ S ≈⟨ p.commute S ⟩ | ||
| λg (arr S ∘ eval′) ∘ p.p₂ S ≈⟨ subst ○ λ-cong assoc ⟩ | ||
| λg (arr S ∘ eval′ ∘ first (p.p₂ S)) ∎ | ||
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
For these longer proofs, best to put them either in
whereor named in a private block. Purely for efficiency.