open import Cat.Functor.Adjoint.Compose
open import Cat.CartesianClosed.Base
open import Cat.Diagram.Limit.Finite
open import Cat.Functor.Bifunctor
open import Cat.Instances.Functor
open import Cat.Diagram.Pullback
open import Cat.Functor.Pullback
open import Cat.Diagram.Product
open import Cat.Functor.Adjoint
open import Cat.Instances.Slice
open import Cat.Prelude

import Cat.Reasoning

module Cat.CartesianClosed.Locally where

Locally Cartesian Closed CategoriesπŸ”—

A finitely complete category C\mathcal{C} is said to be locally Cartesian closed when each of its slice categories is Cartesian closed. In practice, though, it is easier to express this property in terms of a certain family of functors existing.

A finitely complete category C\mathcal{C} is locally cartesian closed when each of its base change functors fβˆ—:C/xβ†’C/yf^* : \mathcal{C}/x \to \mathcal{C}/y admit a right adjoint ∏f:C/yβ†’C/x\prod_f : \mathcal{C}/y \to \mathcal{C}/x, called the dependent sum, thus extending the existing dependent sum-base change adjunction to an adjoint triple

βˆ‘f⊣fβˆ—βˆf \textstyle\sum_f \dashv f* \textstyle\prod_f

record is-lcc {o β„“} (C : Precategory o β„“) : Type (o βŠ” β„“) where
  open Cat.Reasoning C

    finitely-complete : Finitely-complete C

  open Finitely-complete finitely-complete public

  base-change : βˆ€ {a b} β†’ Hom a b β†’ Functor (Slice C b) (Slice C a)
  base-change = Base-change pullbacks

    Ξ f    : βˆ€ {a b} β†’ Hom a b β†’ Functor (Slice C a) (Slice C b)
    f*⊣Πf : βˆ€ {a b} (f : Hom a b) β†’ base-change f ⊣ Ξ f f

Note that the slices of a finitely complete category C\mathcal{C} are automatically Cartesian categories, since products in C/a\mathcal{C}/a are computed as pullbacks in C\mathcal{C}.

  module /-Prods (a : Ob) = Binary-products (Slice C a)
    (λ A B → Pullback→Fibre-product (pullbacks (A .map) (B .map)))

Internal homsπŸ”—

We now calculate that each slice of C\mathcal{C} is a cartesian closed category, by exhibiting a right adjoint each of their product functors.

module _ {o β„“} {C : Precategory o β„“} (lcc : is-lcc C) where
  open Cat.Reasoning C
  open is-lcc lcc

  open Functor
  open is-cc

    hom : βˆ€ {a} (f : Slice C a .Precategory.Ob) β†’ Functor _ _
    hom f = Πf (f .map) F∘ base-change (f .map)

    : βˆ€ {a : Ob}
    β†’ is-cc (Slice C a)
        (λ A B → Pullback→Fibre-product (pullbacks (A .map) (B .map)))
  is-lcc→slice-is-cc .terminal = record
    { top  = cut (C ; has⊀ = Slice-terminal-object }

For a map f:xβ†’af : x \to a, the internal hom functor [f,βˆ’][f,-] in C/a\mathcal{C}/a is given by the composite

C/aβ†’fβˆ—C/xβ†’βˆfC/a \mathcal{C}/a \xrightarrow{f^*} \mathcal{C}/x \xrightarrow{\prod_f} \mathcal{C}/a

  is-lcc→slice-is-cc .[_,-] f = hom f

To prove that this is a right adjoint, we use that adjunctions compose and re-express the Cartesian product functor in C/a\mathcal{C}/a as the composite

C/aβ†’fβˆ—C/xβ†’βˆ‘fC/a \mathcal{C}/a \xrightarrow{f^*} \mathcal{C}/x \xrightarrow{\sum_f} \mathcal{C}/a

We then have, since βˆ‘f⊣fβˆ—\sum_f \dashv f^* and fβˆ—βŠ£βˆff^* \dashv \prod_f, the adjunction (βˆ‘ffβˆ—)⊣(∏ffβˆ—)(\sum_f f^*) \dashv (\prod_f f^*).

  is-lccβ†’slice-is-cc {a = a} .tensor⊣hom f = adj where
    module f = /-Obj f

    -- The "good" cartesian product functor. The one we can piece
    -- together.
    tensor = Σf F∘ base-change
    tensor⊣homβ€² : tensor ⊣ hom f
    tensor⊣homβ€² = LF⊣GR (f*⊣Πf _) (Ξ£f⊣f* pullbacks

    -- The product functor we have to give an adjoint to...
    product = Binary-products.×-functor (Slice C a) (λ A B → Pullback→Fibre-product (pullbacks (A .map) (B .map)))
    aΓ—- = Left product f

    -- ... is the same that we already proved is left adjoint to hom!
    tensor-is-product : tensor ≑ aΓ—-
    tensor-is-product = Functor-path p1 p2 where
      p1 : βˆ€ x β†’ Fβ‚€ tensor x ≑ Fβ‚€ aΓ—- x
      p1 x = /-Obj-path refl (sym (pullbacks (x .map) .Pullback.square))

      p2 : βˆ€ {x y} (g : Slice C a .Precategory.Hom x y)
         β†’ PathP (Ξ» i β†’ /-Hom (p1 x i) (p1 y i)) (F₁ tensor g) (F₁ aΓ—- g)
      p2 {x} {y} g =
        /-Hom-pathp _ _ (Pullback.uniqueβ‚‚ (pullbacks (y .map) (f .map)) {p = path}
          (Pullback.pβ‚βˆ˜universal (pullbacks _ _)) (Pullback.pβ‚‚βˆ˜universal (pullbacks _ _))
          (Pullback.pβ‚βˆ˜universal (pullbacks _ _)) (Pullback.pβ‚‚βˆ˜universal (pullbacks _ _) βˆ™ idl _))
          path =
            y .map ∘ g .map ∘ Pullback.p₁ (pullbacks _ _) β‰‘βŸ¨ pulll (g .commutes) βŸ©β‰‘
            x .map ∘ Pullback.p₁ (pullbacks _ _)          β‰‘βŸ¨ Pullback.square (pullbacks _ _) βŸ©β‰‘
            f .map ∘ Pullback.pβ‚‚ (pullbacks _ _)          ∎

    adj : aΓ—- ⊣ hom f
    adj = subst (_⊣ hom f) tensor-is-product tensor⊣homβ€²