open import 1Lab.Reflection.Copattern

open import Cat.Diagram.Pullback.Properties
open import Cat.Displayed.Cocartesian.Weak
open import Cat.Displayed.Cocartesian
open import Cat.Displayed.Univalence
open import Cat.Displayed.Cartesian
open import Cat.Instances.Functor
open import Cat.Diagram.Pullback
open import Cat.Diagram.Product
open import Cat.Displayed.Fibre
open import Cat.Displayed.Base
open import Cat.Diagram.Image
open import Cat.Prelude

open import Order.Base
open import Order.Cat

import Cat.Reasoning as Cr

module Cat.Displayed.Instances.Subobjects
  {o ℓ} (B : Precategory o ℓ)
  where

open Cr B
open Displayed

The fibration of subobjects🔗

Given a base category $B,$ we can define the displayed category of subobjects over $B .$ This is, in essence, a restriction of the codomain fibration of $B,$ but with our attention restricted to the monomorphisms $a ↪ b$ rather than arbitrary maps $a \to b .$

record Subobject (y : Ob) : Type (o ⊔ ℓ) where
  no-eta-equality
  field
    {dom} : Ob
    map   : Hom dom y
    monic : is-monic map

open Subobject public

To make formalisation smoother, we define our own version of displayed morphisms in the subobject fibration, rather than reusing those of the fundamental self-indexing. The reason for this is quite technical: the type of maps in the self-indexing is only dependent (the domains and) the morphisms being considered, meaning nothing constrains the proofs that these are monomorphisms, causing unification to fail at the determining the full Subobjects involved.

record ≤-over {x y} (f : Hom x y) (a : Subobject x) (b : Subobject y) : Type ℓ where
  no-eta-equality
  field
    map : Hom (a .dom) (b .dom)
    com : f ∘ Subobject.map a ≡ Subobject.map b ∘ map

open ≤-over public

We will denote the type of maps $x^{'} \to_{f} y^{'}$ in the subobject fibration by $x^{'} \leq_{f} y^{'},$ since there is at most one such map: if $g, h$ satisfy $y^{'} g = f x^{'} = y^{'} h,$ then, since $y^{'}$ is a mono, $g = h .$

{-# INLINE Subobject.constructor #-}
≤-over-is-prop
  : ∀ {x y} {f : Hom x y} {a : Subobject x} {b : Subobject y}
  → (p q : ≤-over f a b)
  → p ≡ q
≤-over-is-prop {f = f} {a} {b} p q = path where
  maps : p .map ≡ q .map
  maps = b .monic (p .map) (q .map) (sym (p .com) ∙ q .com)

  path : p ≡ q
  path i .map = maps i
  path i .com = is-prop→pathp (λ i → Hom-set _ _ (f ∘ a .map) (b .map ∘ maps i)) (p .com) (q .com) i

instance
  H-Level-≤-over
    : ∀ {x y} {f : Hom x y} {a : Subobject x} {b : Subobject y} {n}
    → H-Level (≤-over f a b) (suc n)
  H-Level-≤-over = prop-instance ≤-over-is-prop

Setting up the displayed category is now nothing more than routine verification: the identity map satisfies $id a = a id,$ and commutative squares can be pasted together.

Subobjects : Displayed B (o ⊔ ℓ) ℓ
Subobjects .Ob[_] y = Subobject y
Subobjects .Hom[_]  = ≤-over
Subobjects .Hom[_]-set f a b = hlevel 2

Subobjects .id' .map = id
Subobjects .id' .com = id-comm-sym

Subobjects ._∘'_ α β .map = α .map ∘ β .map
Subobjects ._∘'_ α β .com = pullr (β .com) ∙ extendl (α .com)

Subobjects .idr' _       = prop!
Subobjects .idl' _       = prop!
Subobjects .assoc' _ _ _ = prop!
Subobjects .hom[_] p f .map = f .map
Subobjects .hom[_] p f .com = ap₂ _∘_ (sym p) refl ∙ f .com
Subobjects .coh[_] p f = prop!

open Weak-cocartesian-lift
open is-weak-cocartesian
open Cartesian-lift
open is-cartesian
open Pullback

As a fibration🔗

By exactly the same construction as for the fundamental self-indexing, if $B$ has pullbacks, the displayed category we have built is actually a fibration. The construction is slightly simpler now that we have no need to worry about uniqueness, but we can remind ourselves of the universal property:

On the first stage, we are given the data in black: we can complete an open span $y^{'} ↪ y f x$ to a Cartesian square (in blue) by pulling $y^{'}$ back along $f;$ this base change remains a monomorphism. Now given the data in red, we verify that the dashed arrow exists, which is enough for its uniqueness.

module with-pullbacks (pb : has-pullbacks B) where

  -- The blue square:
  pullback-subobject
    : ∀ {X Y} (h : Hom X Y) (g : Subobject Y)
    → Subobject X
  pullback-subobject h g .dom = pb h (g .map) .apex
  pullback-subobject h g .map = pb h (g .map) .p₁
  pullback-subobject h g .monic = is-monic→pullback-is-monic
    (g .monic) (rotate-pullback (pb h (g .map) .has-is-pb))

  Subobject-fibration : Cartesian-fibration Subobjects
  Subobject-fibration f y' = l where
    it : Pullback _ _ _
    it = pb (y' .map) f
    l : Cartesian-lift Subobjects f y'

    l .x' = pullback-subobject f y'
    l .lifting .map = pb f (y' .map) .p₂
    l .lifting .com = pb f (y' .map) .square

    -- The dashed red arrow:
    l .cartesian .universal {u' = u'} m h' = λ where
      .map → pb f (y' .map) .universal (pushr refl ∙ h' .com)
      .com → sym (pb f (y' .map) .p₁∘universal)
    l .cartesian .commutes _ _ = prop!
    l .cartesian .unique _ _   = prop!

As a (weak) cocartesian fibration🔗

If $B$ has an image factorisation for every morphism, then its fibration of subobjects is a weak cocartesian fibration. By a general fact, if $B$ also has pullbacks, then $Sub (-)$ is a cocartesian fibration.

Subobject-weak-opfibration
  : (∀ {x y} (f : Hom x y) → Image B f)
  → Weak-cocartesian-fibration Subobjects
Subobject-weak-opfibration ims f x' = l where
  module im = Image B (ims (f ∘ x' .map))

To understand this result, we remind ourselves of the universal property of an image factorisation for $f : a \to b :$ It is the initial subobject through with $f$ factors. That is to say, if $m : Sub (b)$ is another subobject, and $f = m e$ for some map $e : a \to m,$ then $m \leq im f .$ Summarised diagrammatically, the universal property of an image factorisation looks like a kite:

Now compare this with the universal property required of a weak co-cartesian lift:

By smooshing the corner $x^{'} ↪ x \to y$ together (i.e., composing $x^{'}$ and $f),$ we see that this is exactly the kite-shaped universal property of $im f x^{'} .$

  l : Weak-cocartesian-lift Subobjects f x'
  l .y' .dom   = im.Im
  l .y' .map   = im.Im→codomain
  l .y' .monic = im.Im→codomain-is-M

  l .lifting .map = im.corestrict
  l .lifting .com = sym im.image-factors

  l .weak-cocartesian .universal {x' = y'} h .map = im.universal _ (y' .monic) (h .map) (sym (h .com))
  l .weak-cocartesian .universal h .com = idl _ ∙ sym im.universal-factors

  l .weak-cocartesian .commutes g' = prop!
  l .weak-cocartesian .unique _ _  = prop!

The aforementioned general fact says that any cartesian and weak cocartesian fibration must actually be a full opfibration.

Subobject-opfibration
  : (∀ {x y} (f : Hom x y) → Image B f)
  → (pb : has-pullbacks B)
  → Cocartesian-fibration Subobjects
Subobject-opfibration images pb = fibration+weak-opfibration→opfibration _
  (with-pullbacks.Subobject-fibration pb)
  (Subobject-weak-opfibration images)

Subobjects over a base🔗

We define the category $Sub (y)$ of subobjects of $y$ as a fibre of the subobject fibration.

Sub : Ob → Precategory (o ⊔ ℓ) ℓ
Sub y = record { Precategory (Fibre Subobjects y) }

module Sub {y} = Cr (Sub y)

_≤ₘ_ : ∀ {y} (a b : Subobject y) → Type _
_≤ₘ_ = ≤-over id

≤ₘ→monic : ∀ {y} {a b : Subobject y} → (f : a ≤ₘ b) → is-monic (f .map)
≤ₘ→monic {a = a} f g h α = a .monic g h $
  a .map ∘ g      ≡⟨ ap (_∘ g) (introl refl ∙ f .com) ∙ pullr refl ⟩
  _ ∘ f .map ∘ g  ≡⟨ ap₂ _∘_ refl α ⟩
  _ ∘ f .map ∘ h  ≡⟨ pulll (sym (f .com) ∙ idl _) ⟩
  a .map ∘ h      ∎

≤ₘ→mono : ∀ {y} {a b : Subobject y} → a ≤ₘ b → a .dom ↪ b .dom
≤ₘ→mono f .mor = f .map
≤ₘ→mono {a = a} f .monic = ≤ₘ→monic f

cutₛ : ∀ {x y} {f : Hom x y} → is-monic f → Subobject y
cutₛ x .dom   = _
cutₛ x .map   = _
cutₛ x .monic = x

Sub-antisym
  : ∀ {y} {a b : Subobject y}
  → a ≤ₘ b
  → b ≤ₘ a
  → a Sub.≅ b
Sub-antisym f g = Sub.make-iso f g prop! prop!

Sub-path
  : ∀ {y} {a b : Subobject y}
  → (p : a .dom ≡ b .dom)
  → PathP (λ i → Hom (p i) y) (a .map) (b .map)
  → a ≡ b
Sub-path p q i .dom = p i
Sub-path p q i .map = q i
Sub-path {a = a} {b = b} p q i .monic {c} =
  is-prop→pathp (λ i → Π-is-hlevel³ 1 λ (g h : Hom c (p i)) (_ : q i ∘ g ≡ q i ∘ h) → Hom-set _ _ g h)
    (a .monic) (b .monic) i

Fibrewise cartesian structure🔗

Since products in slice categories are given by pullbacks, and pullbacks preserve monomorphisms, if $B$ has pullbacks, then $Sub (y)$ has products, regardless of what $y$ is.

Sub-products
  : ∀ {y}
  → has-pullbacks B
  → has-products (Sub y)
Sub-products {y} pb a b = prod where
  it = pb (a .map) (b .map)

  prod : Product (Sub y) a b
  prod .Product.apex .dom = it .apex
  prod .Product.apex .map = a .map ∘ it .p₁
  prod .Product.apex .monic = ∘-is-monic
    (a .monic)
    (is-monic→pullback-is-monic (b .monic) (rotate-pullback (it .has-is-pb)))

  prod .Product.π₁ .map = it .p₁
  prod .Product.π₁ .com = idl _

  prod .Product.π₂ .map = it .p₂
  prod .Product.π₂ .com = idl _ ∙ it .square

  prod .Product.has-is-product .is-product.⟨_,_⟩ q≤a q≤b .map =
    it .Pullback.universal {p₁' = q≤a .map} {p₂' = q≤b .map} (sym (q≤a .com) ∙ q≤b .com)
  prod .Product.has-is-product .is-product.⟨_,_⟩ q≤a q≤b .com =
    idl _ ∙ sym (pullr (it .p₁∘universal) ∙ sym (q≤a .com) ∙ idl _)
  prod .Product.has-is-product .is-product.π₁∘⟨⟩ = prop!
  prod .Product.has-is-product .is-product.π₂∘⟨⟩ = prop!
  prod .Product.has-is-product .is-product.unique _ _ = prop!

Univalence🔗

Since identity of $m, n : Sub (y)$ is given by identity of the underlying objects and identity-over of the corresponding morphisms, if $B$ is univalent, we can conclude that $Sub (y)$ is, too. Since $Sub (y)$ is always thin, we can summarise the situation by saying that $Sub (y)$ is a partial order if $B$ is univalent.

Sub-is-category : ∀ {y} → is-category B → is-category (Sub y)
Sub-is-category b-cat .to-path {a} {b} x =
  Sub-path
    (b-cat .to-path i)
    (Univalent.Hom-pathp-refll-iso b-cat (sym (x .Sub.from .com) ∙ idl _))
  where
    i : a .dom ≅ b .dom
    i = make-iso (x .Sub.to .map) (x .Sub.from .map) (ap map (Sub.invl x)) (ap map (Sub.invr x))
Sub-is-category b-cat .to-path-over p =
  Sub.≅-pathp refl _ prop!

As a consequence, the collection of subobjects of any object of a univalent category forms a set.

Subobject-is-set : is-category B → ∀ {A} → is-set (Subobject A)
Subobject-is-set b-cat {A} = Poset.Ob-is-set $
  thin→poset (Sub A) (λ _ _ → ≤-over-is-prop) (Sub-is-category b-cat)