open import Cat.Instances.Product
open import Cat.Prelude

import Cat.Reasoning

module Cat.Diagram.Product where

module _ {o ℓ} (C : Precategory o ℓ) where
  open Cat.Reasoning C

Products🔗

In the sense that (univalent) categories generalise posets, the product of $A$ and $B$ — if it exists — generalises the binary meet $A\wedge B\text{.}$ Since products are unique when they exist, we may safely denote any product of $A$ and $B$ by $A\times B\text{.}$

For a diagram $A\leftarrow A\times B\to B$ to be a product diagram, it must be able to cough up an arrow $Q\to P$ given the data of another span $A\leftarrow Q\to B\text{,}$ which must not only fit into the diagram above but be unique among the arrows that do so.

This factoring is called the pairing of the arrows $f:Q\to A$ and $g:Q\to B\text{,}$ since in the special case where $Q$ is the terminal object (hence the two arrows are global elements of $A$ resp. $B\text{),}$ the pairing $⟨f,g⟩$ is a global element of the product $A\times B\text{.}$

  record is-product {A B P} (π₁ : Hom P A) (π₂ : Hom P B) : Type (o ⊔ ℓ) where
    field
      ⟨_,_⟩ : ∀ {Q} (p1 : Hom Q A) (p2 : Hom Q B) → Hom Q P
      π₁∘⟨⟩ : ∀ {Q} {p1 : Hom Q _} {p2} → π₁ ∘ ⟨ p1 , p2 ⟩ ≡ p1
      π₂∘⟨⟩ : ∀ {Q} {p1 : Hom Q _} {p2} → π₂ ∘ ⟨ p1 , p2 ⟩ ≡ p2

      unique : ∀ {Q} {p1 : Hom Q A} {p2}
             → {other : Hom Q P}
             → π₁ ∘ other ≡ p1
             → π₂ ∘ other ≡ p2
             → other ≡ ⟨ p1 , p2 ⟩

    unique₂ : ∀ {Q} {pr1 : Hom Q A} {pr2}
            → ∀ {o1} (p1 : π₁ ∘ o1 ≡ pr1) (q1 : π₂ ∘ o1 ≡ pr2)
            → ∀ {o2} (p2 : π₁ ∘ o2 ≡ pr1) (q2 : π₂ ∘ o2 ≡ pr2)
            → o1 ≡ o2
    unique₂ p1 q1 p2 q2 = unique p1 q1 ∙ sym (unique p2 q2)

    ⟨⟩∘ : ∀ {Q R} {p1 : Hom Q A} {p2 : Hom Q B} (f : Hom R Q)
        → ⟨ p1 , p2 ⟩ ∘ f ≡ ⟨ p1 ∘ f , p2 ∘ f ⟩
    ⟨⟩∘ f = unique (pulll π₁∘⟨⟩) (pulll π₂∘⟨⟩)

    ⟨⟩-η : ⟨ π₁ , π₂ ⟩ ≡ id
    ⟨⟩-η = sym $ unique (idr _) (idr _)

A product of $A$ and $B$ is an explicit choice of product diagram:

  record Product (A B : Ob) : Type (o ⊔ ℓ) where
    no-eta-equality
    field
      apex : Ob
      π₁ : Hom apex A
      π₂ : Hom apex B
      has-is-product : is-product π₁ π₂

    open is-product has-is-product public

module _ {o ℓ} {C : Precategory o ℓ} where
  open Cat.Reasoning C
  open Product hiding (⟨_,_⟩ ; π₁ ; π₂ ; ⟨⟩∘)
  private variable
    A B a b c d : Ob

  is-product-is-prop : ∀ {X Y P} {p₁ : Hom P X} {p₂ : Hom P Y} → is-prop (is-product C p₁ p₂)
  is-product-is-prop {X = X} {Y = Y} {p₁ = p₁} {p₂} x y = q where
    open is-product
    p : Path (∀ {P'} → Hom P' X → Hom P' Y → _) (x .⟨_,_⟩) (y .⟨_,_⟩)
    p i p1 p2 = y .unique {p1 = p1} {p2} (x .π₁∘⟨⟩) (x .π₂∘⟨⟩) i
    q : x ≡ y
    q i .⟨_,_⟩ = p i
    q i .π₁∘⟨⟩ {p1 = p1} {p2} = is-prop→pathp (λ i → Hom-set _ _ (p₁ ∘ p i p1 p2) p1) (x .π₁∘⟨⟩) (y .π₁∘⟨⟩) i
    q i .π₂∘⟨⟩ {p1 = p1} {p2} = is-prop→pathp (λ i → Hom-set _ _ (p₂ ∘ p i p1 p2) p2) (x .π₂∘⟨⟩) (y .π₂∘⟨⟩) i
    q i .unique {p1 = p1} {p2} {other} c₁ c₂ = is-prop→pathp (λ i → Hom-set _ _ other (p i p1 p2)) (x .unique c₁ c₂) (y .unique c₁ c₂) i

  instance
    H-Level-is-product : ∀ {X Y P} {p₁ : Hom P X} {p₂ : Hom P Y} {n} → H-Level (is-product C p₁ p₂) (suc n)
    H-Level-is-product = prop-instance is-product-is-prop

Uniqueness🔗

Products, when they exist, are unique. It’s easiest to see this with a diagrammatic argument: If we have product diagrams $A\leftarrow P\to B$ and $A\leftarrow P^{\prime }\to B\text{,}$ we can fit them into a “commutative diamond” like the one below:

Since both $P$ and $P^{\prime }$ are products, we know that the dashed arrows in the diagram below exist, so the overall diagram commutes: hence we have an isomorphism $P\cong P^{\prime }\text{.}$

We construct the map $P\to P^{\prime }$ as the pairing of the projections from $P\text{,}$ and symmetrically for $P^{\prime }\to P\text{.}$

  ×-Unique : (p1 p2 : Product C A B) → apex p1 ≅ apex p2
  ×-Unique p1 p2 = make-iso p1→p2 p2→p1 p1→p2→p1 p2→p1→p2 where
    module p1 = Product p1
    module p2 = Product p2

    p1→p2 : Hom (apex p1) (apex p2)
    p1→p2 = p2.⟨ p1.π₁ , p1.π₂ ⟩p2.

    p2→p1 : Hom (apex p2) (apex p1)
    p2→p1 = p1.⟨ p2.π₁ , p2.π₂ ⟩p1.

These are unique because they are maps into products which commute with the projections.

    p1→p2→p1 : p1→p2 ∘ p2→p1 ≡ id
    p1→p2→p1 = p2.unique₂
      (assoc _ _ _ ∙∙ ap (_∘ _) p2.π₁∘⟨⟩ ∙∙ p1.π₁∘⟨⟩)
      (assoc _ _ _ ∙∙ ap (_∘ _) p2.π₂∘⟨⟩ ∙∙ p1.π₂∘⟨⟩)
      (idr _) (idr _)

    p2→p1→p2 : p2→p1 ∘ p1→p2 ≡ id
    p2→p1→p2 = p1.unique₂
      (assoc _ _ _ ∙∙ ap (_∘ _) p1.π₁∘⟨⟩ ∙∙ p2.π₁∘⟨⟩)
      (assoc _ _ _ ∙∙ ap (_∘ _) p1.π₂∘⟨⟩ ∙∙ p2.π₂∘⟨⟩)
      (idr _) (idr _)

  is-product-iso
    : ∀ {A A' B B' P} {π₁ : Hom P A} {π₂ : Hom P B}
        {f : Hom A A'} {g : Hom B B'}
    → is-invertible f
    → is-invertible g
    → is-product C π₁ π₂
    → is-product C (f ∘ π₁) (g ∘ π₂)
  is-product-iso f-iso g-iso prod = prod' where
    module fi = is-invertible f-iso
    module gi = is-invertible g-iso

    open is-product
    prod' : is-product _ _ _
    prod' .⟨_,_⟩ qa qb = prod .⟨_,_⟩ (fi.inv ∘ qa) (gi.inv ∘ qb)
    prod' .π₁∘⟨⟩ = pullr (prod .π₁∘⟨⟩) ∙ cancell fi.invl
    prod' .π₂∘⟨⟩ = pullr (prod .π₂∘⟨⟩) ∙ cancell gi.invl
    prod' .unique p q = prod .unique
      (sym (ap (_ ∘_) (sym p) ∙ pulll (cancell fi.invr)))
      (sym (ap (_ ∘_) (sym q) ∙ pulll (cancell gi.invr)))

  is-product-iso-apex
    : ∀ {A B P P'} {π₁ : Hom P A} {π₂ : Hom P B}
        {π₁' : Hom P' A} {π₂' : Hom P' B}
        {f : Hom P' P}
    → is-invertible f
    → π₁ ∘ f ≡ π₁'
    → π₂ ∘ f ≡ π₂'
    → is-product C π₁ π₂
    → is-product C π₁' π₂'
  is-product-iso-apex {f = f} f-iso f-π₁ f-π₂ prod = prod' where
    module fi = is-invertible f-iso

    open is-product
    prod' : is-product _ _ _
    prod' .⟨_,_⟩ qa qb = fi.inv ∘ prod .⟨_,_⟩ qa qb
    prod' .π₁∘⟨⟩ = pulll (rswizzle (sym f-π₁) fi.invl) ∙ prod .π₁∘⟨⟩
    prod' .π₂∘⟨⟩ = pulll (rswizzle (sym f-π₂) fi.invl) ∙ prod .π₂∘⟨⟩
    prod' .unique p q = sym $ lswizzle
      (sym (prod .unique (pulll f-π₁ ∙ p) (pulll f-π₂ ∙ q))) fi.invr

Categories with all binary products🔗

Categories with all binary products are quite common, so we define a module for working with them.

has-products : ∀ {o ℓ} → Precategory o ℓ → Type _
has-products C = ∀ a b → Product C a b

module Binary-products
  {o ℓ} (C : Precategory o ℓ) (all-products : has-products C) where

  open Cat.Reasoning C
  private variable
    A B a b c d : Ob

  -- Note: here and below we have to open public the aliases in a module
  -- with parameters so Agda picks up the display forms.
  module _ {a b} where
    open Product (all-products a b)
      renaming (unique to ⟨⟩-unique; unique₂ to ⟨⟩-unique₂)
      hiding (apex)
      public
  open Functor

  infix  _⊗₁_

We start by defining a “global” product-assigning operation.

  module _ a b where
    open Product (all-products a b)
      renaming (apex to infixr  _⊗₀_)
      using () public

This operation extends to a bifunctor $\mathcal{C}\times \mathcal{C}\to \mathcal{C}\text{.}$

  _⊗₁_ : ∀ {a b x y} → Hom a x → Hom b y → Hom (a ⊗₀ b) (x ⊗₀ y)
  f ⊗₁ g = ⟨ f ∘ π₁ , g ∘ π₂ ⟩

  ×-functor : Functor (C ×ᶜ C) C
  ×-functor .F₀ (a , b) = a ⊗₀ b
  ×-functor .F₁ (f , g) = f ⊗₁ g
  ×-functor .F-id = sym $ ⟨⟩-unique id-comm id-comm
  ×-functor .F-∘ (f , g) (h , i) =
    sym $ ⟨⟩-unique
      (pulll π₁∘⟨⟩ ∙ extendr π₁∘⟨⟩)
      (pulll π₂∘⟨⟩ ∙ extendr π₂∘⟨⟩)

We also define a handful of common morphisms.

  δ : Hom a (a ⊗₀ a)
  δ = ⟨ id , id ⟩

  swap : Hom (a ⊗₀ b) (b ⊗₀ a)
  swap = ⟨ π₂ , π₁ ⟩

  ×-assoc : Hom (a ⊗₀ (b ⊗₀ c)) ((a ⊗₀ b) ⊗₀ c)
  ×-assoc = ⟨ ⟨ π₁ , π₁ ∘ π₂ ⟩ , π₂ ∘ π₂ ⟩

  δ-natural : is-natural-transformation Id (×-functor F∘ Cat⟨ Id , Id ⟩Cat) λ _ → δ
  δ-natural x y f = ⟨⟩-unique₂
    (cancell π₁∘⟨⟩) (cancell π₂∘⟨⟩)
    (pulll π₁∘⟨⟩ ∙ cancelr π₁∘⟨⟩) (pulll π₂∘⟨⟩ ∙ cancelr π₂∘⟨⟩)

  swap-is-iso : ∀ {a b} → is-invertible (swap {a} {b})
  swap-is-iso = make-invertible swap
    (⟨⟩-unique₂ (pulll π₁∘⟨⟩ ∙ π₂∘⟨⟩) ((pulll π₂∘⟨⟩ ∙ π₁∘⟨⟩)) (idr _) (idr _))
    (⟨⟩-unique₂ (pulll π₁∘⟨⟩ ∙ π₂∘⟨⟩) ((pulll π₂∘⟨⟩ ∙ π₁∘⟨⟩)) (idr _) (idr _))

  swap-natural
    : ∀ {A B C D} ((f , g) : Hom A C × Hom B D)
    → (g ⊗₁ f) ∘ swap ≡ swap ∘ (f ⊗₁ g)
  swap-natural (f , g) =
    (g ⊗₁ f) ∘ swap                       ≡⟨ ⟨⟩∘ _ ⟩≡
    ⟨ (g ∘ π₁) ∘ swap , (f ∘ π₂) ∘ swap ⟩ ≡⟨ ap₂ ⟨_,_⟩ (pullr π₁∘⟨⟩) (pullr π₂∘⟨⟩) ⟩≡
    ⟨ g ∘ π₂ , f ∘ π₁ ⟩                   ≡˘⟨ ap₂ ⟨_,_⟩ π₂∘⟨⟩ π₁∘⟨⟩ ⟩≡˘
    ⟨ π₂ ∘ (f ⊗₁ g) , π₁ ∘ (f ⊗₁ g) ⟩     ≡˘⟨ ⟨⟩∘ _ ⟩≡˘
    swap ∘ (f ⊗₁ g)                       ∎

  swap-δ : ∀ {A} → swap ∘ δ ≡ δ {A}
  swap-δ = ⟨⟩-unique (pulll π₁∘⟨⟩ ∙ π₂∘⟨⟩) (pulll π₂∘⟨⟩ ∙ π₁∘⟨⟩)

  assoc-δ : ∀ {a} → ×-assoc ∘ (id ⊗₁ δ {a}) ∘ δ {a} ≡ (δ ⊗₁ id) ∘ δ
  assoc-δ = ⟨⟩-unique₂
    (pulll π₁∘⟨⟩ ∙ ⟨⟩-unique₂
      (pulll π₁∘⟨⟩ ∙ pulll π₁∘⟨⟩ ∙ pullr π₁∘⟨⟩)
      (pulll π₂∘⟨⟩ ∙ pullr (pulll π₂∘⟨⟩) ∙ pulll (pulll π₁∘⟨⟩) ∙ pullr π₂∘⟨⟩)
      (pulll (pulll π₁∘⟨⟩) ∙ pullr π₁∘⟨⟩)
      (pulll (pulll π₂∘⟨⟩) ∙ pullr π₁∘⟨⟩)
    ∙ pushl (sym π₁∘⟨⟩))
    (pulll π₂∘⟨⟩ ∙ pullr (pulll π₂∘⟨⟩) ∙ pulll (pulll π₂∘⟨⟩) ∙ pullr π₂∘⟨⟩)
    refl
    (pulll π₂∘⟨⟩ ∙ pullr π₂∘⟨⟩)

  by-π₁ : ∀ {f f' : Hom a b} {g g' : Hom a c} → ⟨ f , g ⟩ ≡ ⟨ f' , g' ⟩ → f ≡ f'
  by-π₁ p = sym π₁∘⟨⟩ ∙ ap (π₁ ∘_) p ∙ π₁∘⟨⟩

  extend-π₁ : ∀ {f : Hom a b} {g : Hom a c} {h} → ⟨ f , g ⟩ ≡ h → f ≡ π₁ ∘ h
  extend-π₁ p = sym π₁∘⟨⟩ ∙ ap (π₁ ∘_) p

  by-π₂ : ∀ {f f' : Hom a b} {g g' : Hom a c} → ⟨ f , g ⟩ ≡ ⟨ f' , g' ⟩ → g ≡ g'
  by-π₂ p = sym π₂∘⟨⟩ ∙ ap (π₂ ∘_) p ∙ π₂∘⟨⟩

  extend-π₂ : ∀ {f : Hom a b} {g : Hom a c} {h} → ⟨ f , g ⟩ ≡ h → g ≡ π₂ ∘ h
  extend-π₂ p = sym π₂∘⟨⟩ ∙ ap (π₂ ∘_) p

  π₁-inv
    : ∀ {f : Hom (a ⊗₀ b) c} {g : Hom (a ⊗₀ b) d}
    → (⟨⟩-inv : is-invertible ⟨ f , g ⟩)
    → f ∘ is-invertible.inv ⟨⟩-inv ≡ π₁
  π₁-inv {f = f} {g = g} ⟨⟩-inv =
    pushl (sym π₁∘⟨⟩) ∙ elimr (is-invertible.invl ⟨⟩-inv)

  π₂-inv
    : ∀ {f : Hom (a ⊗₀ b) c} {g : Hom (a ⊗₀ b) d}
    → (⟨⟩-inv : is-invertible ⟨ f , g ⟩)
    → g ∘ is-invertible.inv ⟨⟩-inv ≡ π₂
  π₂-inv {f = f} {g = g} ⟨⟩-inv =
    pushl (sym π₂∘⟨⟩) ∙ elimr (is-invertible.invl ⟨⟩-inv)

Representability of products🔗

module _ {o ℓ} {C : Precategory o ℓ} where
  open Cat.Reasoning C

The collection of maps into a product $a\times b$ is equivalent to the collection of pairs of maps into $a$ and $b\text{.}$ The forward direction of the equivalence is given by postcomposition of the projections, and the reverse direction by the universal property of products.

  product-repr
    : ∀ {a b}
    → (prod : Product C a b)
    → (x : Ob)
    → Hom x (Product.apex prod) ≃ (Hom x a × Hom x b)
  product-repr prod x = Iso→Equiv λ where
      .fst f → π₁ ∘ f , π₂ ∘ f
      .snd .is-iso.from (f , g) → ⟨ f , g ⟩
      .snd .is-iso.rinv (f , g) → π₁∘⟨⟩ ,ₚ π₂∘⟨⟩
      .snd .is-iso.linv f → sym (⟨⟩∘ f) ∙ eliml ⟨⟩-η
    where open Product prod