cat/src/Cat/Categories/Sets.agda

-- | The category of homotopy sets
{-# OPTIONS --allow-unsolved-metas --cubical #-}
module Cat.Categories.Sets where

open import Agda.Primitive
open import Data.Product
open import Function using (_∘_)

open import Cubical hiding (_≃_ ; inverse)
open import Cubical.Equivalence
  renaming
    ( _≅_ to _A≅_ )
  using
    (_≃_ ; con ; AreInverses)
open import Cubical.Univalence
open import Cubical.GradLemma

open import Cat.Category
open import Cat.Category.Functor
open import Cat.Category.Product
open import Cat.Wishlist

module _ (ℓ : Level) where
  private
    open import Cubical.Univalence
    open import Cubical.NType.Properties
    open import Cubical.Universe

    SetsRaw : RawCategory (lsuc ℓ) ℓ
    RawCategory.Object SetsRaw = hSet
    RawCategory.Arrow  SetsRaw (T , _) (U , _) = T → U
    RawCategory.𝟙      SetsRaw = Function.id
    RawCategory._∘_    SetsRaw = Function._∘′_

    open RawCategory SetsRaw hiding (_∘_)
    open Univalence  SetsRaw

    isIdentity : IsIdentity Function.id
    proj₁ isIdentity = funExt λ _ → refl
    proj₂ isIdentity = funExt λ _ → refl

    arrowsAreSets : ArrowsAreSets
    arrowsAreSets {B = (_ , s)} = setPi λ _ → s

    module _ {hA hB : Object} where
      private
        A = proj₁ hA
        isSetA : isSet A
        isSetA = proj₂ hA
        B = proj₁ hB
        isSetB : isSet B
        isSetB = proj₂ hB

        toIsomorphism : A ≃ B → hA ≅ hB
        toIsomorphism e = obverse , inverse , verso-recto , recto-verso
          where
          open _≃_ e

        fromIsomorphism : hA ≅ hB → A ≃ B
        fromIsomorphism iso = con obverse (gradLemma obverse inverse recto-verso verso-recto)
          where
          obverse : A → B
          obverse = proj₁ iso
          inverse : B → A
          inverse = proj₁ (proj₂ iso)
          -- FIXME IsInverseOf should change name to AreInverses and the
          -- ordering should be swapped.
          areInverses : IsInverseOf {A = hA} {hB} obverse inverse
          areInverses = proj₂ (proj₂ iso)
          verso-recto : ∀ a → (inverse ∘ obverse) a ≡ a
          verso-recto a i = proj₁ areInverses i a
          recto-verso : ∀ b → (obverse Function.∘ inverse) b ≡ b
          recto-verso b i = proj₂ areInverses i b

      private
        univIso : (A ≡ B) A≅ (A ≃ B)
        univIso = _≃_.toIsomorphism univalence
        obverse' : A ≡ B → A ≃ B
        obverse' = proj₁ univIso
        inverse' : A ≃ B → A ≡ B
        inverse' = proj₁ (proj₂ univIso)
        -- Drop proof of being a set from both sides of an equality.
        dropP : hA ≡ hB → A ≡ B
        dropP eq i = proj₁ (eq i)
        -- Add proof of being a set to both sides of a set-theoretic equivalence
        -- returning a category-theoretic equivalence.
        addE : A A≅ B → hA ≅ hB
        addE eqv = proj₁ eqv , (proj₁ (proj₂ eqv)) , asPair
          where
          areeqv = proj₂ (proj₂ eqv)
          asPair =
            let module Inv = AreInverses areeqv
            in Inv.verso-recto , Inv.recto-verso

        obverse : hA ≡ hB → hA ≅ hB
        obverse = addE ∘ _≃_.toIsomorphism ∘ obverse' ∘ dropP

        -- Drop proof of being a set form both sides of a category-theoretic
        -- equivalence returning a set-theoretic equivalence.
        dropE : hA ≅ hB → A A≅ B
        dropE eqv = obv , inv , asAreInverses
          where
          obv = proj₁ eqv
          inv = proj₁ (proj₂ eqv)
          areEq = proj₂ (proj₂ eqv)
          asAreInverses : AreInverses A B obv inv
          asAreInverses = record { verso-recto = proj₁ areEq ; recto-verso = proj₂ areEq }

        -- Dunno if this is a thing.
        isoToEquiv : A A≅ B → A ≃ B
        isoToEquiv = {!!}
        -- Add proof of being a set to both sides of an equality.
        addP : A ≡ B → hA ≡ hB
        addP p = lemSig (λ X → propPi λ x → propPi (λ y → propIsProp)) hA hB p
        inverse : hA ≅ hB → hA ≡ hB
        inverse = addP ∘ inverse' ∘ isoToEquiv ∘ dropE

        -- open AreInverses (proj₂ (proj₂ univIso)) renaming
        --   ( verso-recto to verso-recto'
        --   ; recto-verso to recto-verso'
        --   )
        -- I can just open them but I wanna be able to see the type annotations.
        verso-recto' : inverse' ∘ obverse' ≡ Function.id
        verso-recto' = AreInverses.verso-recto (proj₂ (proj₂ univIso))
        recto-verso' : obverse' ∘ inverse' ≡ Function.id
        recto-verso' = AreInverses.recto-verso (proj₂ (proj₂ univIso))
        verso-recto : (iso : hA ≅ hB) → obverse (inverse iso) ≡ iso
        verso-recto iso = begin
          obverse (inverse iso) ≡⟨⟩
          ( addE ∘ _≃_.toIsomorphism
          ∘ obverse' ∘ dropP ∘ addP
          ∘ inverse' ∘ isoToEquiv
          ∘ dropE) iso
            ≡⟨⟩
          ( addE ∘ _≃_.toIsomorphism
          ∘ obverse'
          ∘ inverse' ∘ isoToEquiv
          ∘ dropE) iso
            ≡⟨ {!!} ⟩ -- obverse' inverse' are inverses
          ( addE ∘ _≃_.toIsomorphism ∘ isoToEquiv ∘ dropE) iso
            ≡⟨ {!!} ⟩ -- should be easy to prove
                      -- _≃_.toIsomorphism ∘ isoToEquiv ≡ id
          (addE ∘ dropE) iso
            ≡⟨⟩
          iso ∎

        -- Similar to above.
        recto-verso : (eq : hA ≡ hB) → inverse (obverse eq) ≡ eq
        recto-verso eq = begin
          inverse (obverse eq) ≡⟨ {!!} ⟩
          eq ∎

        -- Use the fact that being an h-level is a mere proposition.
        -- This is almost provable using `Wishlist.isSetIsProp` - although
        -- this creates homogenous paths.
        isSetEq : (p : A ≡ B) → (λ i → isSet (p i)) [ isSetA ≡ isSetB ]
        isSetEq = {!!}

        res : hA ≡ hB
        proj₁ (res i) = {!!}
        proj₂ (res i) = isSetEq {!!} i
      univalent : isEquiv (hA ≡ hB) (hA ≅ hB) (id-to-iso (λ {A} {B} → isIdentity {A} {B}) hA hB)
      univalent = {!gradLemma obverse inverse verso-recto recto-verso!}

    SetsIsCategory : IsCategory SetsRaw
    IsCategory.isAssociative SetsIsCategory = refl
    IsCategory.isIdentity    SetsIsCategory {A} {B} = isIdentity    {A} {B}
    IsCategory.arrowsAreSets SetsIsCategory {A} {B} = arrowsAreSets {A} {B}
    IsCategory.univalent     SetsIsCategory = univalent

  𝓢𝓮𝓽 Sets : Category (lsuc ℓ) ℓ
  Category.raw 𝓢𝓮𝓽 = SetsRaw
  Category.isCategory 𝓢𝓮𝓽 = SetsIsCategory
  Sets = 𝓢𝓮𝓽

module _ {ℓ : Level} where
  private
    𝓢 = 𝓢𝓮𝓽 ℓ
    open Category 𝓢
    open import Cubical.Sigma

    module _ (0A 0B : Object) where
      private
        A : Set ℓ
        A = proj₁ 0A
        sA : isSet A
        sA = proj₂ 0A
        B : Set ℓ
        B = proj₁ 0B
        sB : isSet B
        sB = proj₂ 0B
        0A×0B : Object
        0A×0B = (A × B) , sigPresSet sA λ _ → sB

        module _ {X A B : Set ℓ} (f : X → A) (g : X → B) where
          _&&&_ : (X → A × B)
          _&&&_ x = f x , g x
        module _ {0X : Object} where
          X = proj₁ 0X
          module _ (f : X → A ) (g : X → B) where
            lem : proj₁ Function.∘′ (f &&& g) ≡ f × proj₂ Function.∘′ (f &&& g) ≡ g
            proj₁ lem = refl
            proj₂ lem = refl

        rawProduct : RawProduct 𝓢 0A 0B
        RawProduct.object rawProduct = 0A×0B
        RawProduct.proj₁  rawProduct = Data.Product.proj₁
        RawProduct.proj₂  rawProduct = Data.Product.proj₂

        isProduct : IsProduct 𝓢 _ _ rawProduct
        IsProduct.isProduct isProduct {X = X} f g
          = (f &&& g) , lem {0X = X} f g

      product : Product 𝓢 0A 0B
      Product.raw       product = rawProduct
      Product.isProduct product = isProduct

  instance
    SetsHasProducts : HasProducts 𝓢
    SetsHasProducts = record { product = product }

module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
  -- Covariant Presheaf
  Representable : Set (ℓa ⊔ lsuc ℓb)
  Representable = Functor ℂ (𝓢𝓮𝓽 ℓb)

  -- Contravariant Presheaf
  Presheaf : Set (ℓa ⊔ lsuc ℓb)
  Presheaf = Functor (opposite ℂ) (𝓢𝓮𝓽 ℓb)

  open Category ℂ

  -- The "co-yoneda" embedding.
  representable : Category.Object ℂ → Representable
  representable A = record
    { raw = record
      { omap = λ B → ℂ [ A , B ] , arrowsAreSets
      ; fmap = ℂ [_∘_]
      }
    ; isFunctor = record
      { isIdentity = funExt λ _ → proj₂ isIdentity
      ; isDistributive = funExt λ x → sym isAssociative
      }
    }

  -- Alternate name: `yoneda`
  presheaf : Category.Object (opposite ℂ) → Presheaf
  presheaf B = record
    { raw = record
      { omap = λ A → ℂ [ A , B ] , arrowsAreSets
      ; fmap = λ f g → ℂ [ g ∘ f ]
    }
    ; isFunctor = record
      { isIdentity = funExt λ x → proj₁ isIdentity
      ; isDistributive = funExt λ x → isAssociative
      }
    }