bsc-leon-vatthauer/agda/bsc-thesis/Category.Ambient.Setoids.md

The category of Setoids can be used as instance for ambient category

Most of the required properties are already proven in the agda-categories library, we are only left to construct the natural numbers object.

module Category.Ambient.Setoids {ℓ} where
  open _⟶_ using (cong)

  -- equality on setoid functions
  private
    _≋_ : ∀ {A B : Setoid ℓ ℓ} → A ⟶ B → A ⟶ B → Set ℓ
    _≋_ {A} {B} f g = Setoid._≈_ (A ⇨ B) f g
    ≋-sym : ∀ {A B : Setoid ℓ ℓ} {f g : A ⟶ B} → f ≋ g → g ≋ f
    ≋-sym {A} {B} {f} {g} = IsEquivalence.sym (Setoid.isEquivalence (A ⇨ B)) {f} {g}
    ≋-trans : ∀ {A B : Setoid ℓ ℓ} {f g h : A ⟶ B} → f ≋ g → g ≋ h → f ≋ h
    ≋-trans {A} {B} {f} {g} {h} = IsEquivalence.trans (Setoid.isEquivalence (A ⇨ B)) {f} {g} {h}

  -- we define ℕ ourselves, instead of importing it, to avoid lifting the universe levels (builtin Nats are defined on Set₀)
  data ℕ : Set ℓ where
    zero : ℕ
    suc : ℕ → ℕ

  suc-cong : ∀ {n m} → n ≡ m → suc n ≡ suc m
  suc-cong n≡m rewrite n≡m = Eq.refl

  suc-inj : ∀ {n m} → suc n ≡ suc m → n ≡ m
  suc-inj Eq.refl = Eq.refl

  ℕ-eq : Rel ℕ ℓ
  ℕ-eq zero zero = ⊤
  ℕ-eq zero (suc m) = ⊥
  ℕ-eq (suc n) zero = ⊥
  ℕ-eq (suc n) (suc m) = ℕ-eq n m

  ⊤-setoid : Setoid ℓ ℓ
  ⊤-setoid = record { Carrier = ⊤ ; _≈_ = _≡_ ; isEquivalence = Eq.isEquivalence }

  ℕ-setoid : Setoid ℓ ℓ
  ℕ-setoid = record 
    { Carrier = ℕ 
    ; _≈_ = _≡_ -- ℕ-eq 
    ; isEquivalence = Eq.isEquivalence 
    }
  
  zero⟶ : SingletonSetoid {ℓ} {ℓ} ⟶ ℕ-setoid
  zero⟶ = record { to = λ _ → zero ; cong = λ x → Eq.refl } 
  suc⟶ : ℕ-setoid ⟶ ℕ-setoid
  suc⟶ = record { to = suc ; cong = suc-cong }

  ℕ-universal : ∀ {A : Setoid ℓ ℓ} → SingletonSetoid {ℓ} {ℓ} ⟶ A → A ⟶ A → ℕ-setoid ⟶ A
  ℕ-universal {A} z s = record { to = app ; cong = cong' }
    where
      app : ℕ → Setoid.Carrier A
      app zero = z ⟨$⟩ tt
      app (suc n) = s ⟨$⟩ (app n)
      cong' : ∀ {n m : ℕ} → n ≡ m → Setoid._≈_ A (app n) (app m)
      cong' Eq.refl = IsEquivalence.refl (Setoid.isEquivalence A)
    
  ℕ-z-commute : ∀ {A : Setoid ℓ ℓ} {q : SingletonSetoid {ℓ} {ℓ} ⟶ A} {f : A ⟶ A} → q ≋ (ℕ-universal q f ∘ zero⟶)
  ℕ-z-commute {A} {q} {f} {lift t} = IsEquivalence.refl (Setoid.isEquivalence A)

  ℕ-s-commute : ∀ {A : Setoid ℓ ℓ} {q : SingletonSetoid {ℓ} {ℓ} ⟶ A} {f : A ⟶ A} → (f ∘ (ℕ-universal q f)) ≋ (ℕ-universal q f ∘ suc⟶)
  ℕ-s-commute {A} {q} {f} {n} = IsEquivalence.refl (Setoid.isEquivalence A)

  ℕ-unique : ∀ {A : Setoid ℓ ℓ} {q : SingletonSetoid {ℓ} {ℓ} ⟶ A} {f : A ⟶ A} {u : ℕ-setoid ⟶ A} → q ≋ (u ∘ zero⟶) → (f ∘ u) ≋ (u ∘ suc⟶) → u ≋ ℕ-universal q f
  ℕ-unique {A} {q} {f} {u} qz fs {zero} = ≋-sym {SingletonSetoid} {A} {q} {u ∘ zero⟶} qz
  ℕ-unique {A} {q} {f} {u} qz fs {suc n} = AR.begin 
    u ⟨$⟩ suc n                                            AR.≈⟨ ≋-sym {ℕ-setoid} {A} {f ∘ u} {u ∘ suc⟶} fs ⟩ 
    f ∘ u ⟨$⟩ n                                            AR.≈⟨ cong f (ℕ-unique {A} {q} {f} {u} qz fs {n}) ⟩ 
    f ∘ ℕ-universal q f ⟨$⟩ n                              AR.≈⟨ ℕ-s-commute {A} {q} {f} {n} ⟩ 
    ℕ-universal q f ⟨$⟩ suc n                              AR.∎
    where module AR = SetoidR A

  setoidNNO : NNO (Setoids ℓ ℓ) SingletonSetoid-⊤
  setoidNNO = record 
    { N = ℕ-setoid 
    ; isNNO = record
      { z = zero⟶
      ; s = suc⟶
      ; universal = ℕ-universal
      ; z-commute = λ {A} {q} {f} → ℕ-z-commute {A} {q} {f}
      ; s-commute = λ {A} {q} {f} {n} → ℕ-s-commute {A} {q} {f} {n}
      ; unique = λ {A} {q} {f} {u} qz fs → ℕ-unique {A} {q} {f} {u} qz fs
      }
    }

  setoidAmbient : Ambient (ℓ-suc ℓ) ℓ ℓ
  setoidAmbient = record { C = Setoids ℓ ℓ ; extensive = Setoids-Extensive ℓ ; cartesian = Setoids-Cartesian ; ℕ = NNO×CCC⇒PNNO (record { U = Setoids ℓ ℓ ; cartesianClosed = Setoids-CCC ℓ }) (Cocartesian.coproducts (Setoids-Cocartesian {ℓ} {ℓ})) setoidNNO }