cat/src/Cat/Categories/Rel.agda

170 lines
6.2 KiB
Agda
Raw Normal View History

2018-02-02 14:33:54 +00:00
{-# OPTIONS --cubical --allow-unsolved-metas #-}
module Cat.Categories.Rel where
2017-11-10 15:00:00 +00:00
2018-01-30 10:19:48 +00:00
open import Cubical
2017-11-10 15:00:00 +00:00
open import Cubical.GradLemma
open import Agda.Primitive
open import Data.Product renaming (proj₁ to fst ; proj₂ to snd)
open import Function
import Cubical.FromStdLib
open import Cat.Category
2017-11-10 15:00:00 +00:00
-- Subsets are predicates over some type.
Subset : { : Level} ( A : Set ) Set ( lsuc lzero)
Subset A = A Set
-- Subset : { ' : Level} → ( A : Set ) → Set ( ⊔ lsuc ')
-- Subset {' = '} A = A → Set '
-- {a ∈ A | P a}
-- subset-syntax : { ' : Level} → (A : Set ) → (P : A → Set ') → ( a : A ) → Set '
-- subset-syntax A P a = P a
-- infix 2 subset-syntax
-- syntax subset P a = << a ∈ A >>>
-- syntax subset P = ⦃ a ∈ A | P a ⦄
-- syntax subset-syntax A (λ a → B) = ⟨ a foo A B ⟩
2017-11-15 20:59:00 +00:00
-- Membership is (dependent) function applicatiom.
2017-11-10 15:00:00 +00:00
_∈_ : { : Level} {A : Set } A Subset A Set
s S = S s
infixl 45 _∈_
-- The diagnoal of a set is a synonym for equality.
Diag : S Subset (S × S)
2017-11-15 20:59:00 +00:00
Diag S (x , y) = x y
2017-11-10 15:00:00 +00:00
-- Diag S = subset (S × S) (λ {(p , q) → p ≡ q})
-- Diag S = ⟨ ? foo ? ? ⟩
-- Diag S (s₀ , s₁) = ⦃ (s₀ , s₁) ∈ S | s₀ ≡ s₁ ⦄
module _ {A B : Set} {S : Subset (A × B)} (ab : A × B) where
private
a : A
a = fst ab
b : B
b = snd ab
module _ where
private
forwards : ((a , b) S)
(Σ[ a' A ] (a , a') Diag A × (a' , b) S)
forwards ab∈S = a , (refl , ab∈S)
backwards : (Σ[ a' A ] (a , a') Diag A × (a' , b) S)
(a , b) S
backwards (a' , (a=a' , a'b∈S)) = subst (sym a=a') a'b∈S
fwd-bwd : (x : (a , b) S) (backwards forwards) x x
2017-11-10 15:00:00 +00:00
-- isbijective x = pathJ (λ y x₁ → (backwards ∘ forwards) x ≡ x) {!!} {!!} {!!}
fwd-bwd x = pathJprop (λ y _ y) x
2017-11-10 15:00:00 +00:00
bwd-fwd : (x : Σ[ a' A ] (a , a') Diag A × (a' , b) S)
2017-11-10 15:00:00 +00:00
(forwards backwards) x x
-- bwd-fwd (y , a≡y , z) = ?
bwd-fwd (a' , a≡y , z) = pathJ lem0 lem1 a' a≡y z
where
lem0 = (λ a'' a≡a'' a''b∈S (forwards backwards) (a'' , a≡a'' , a''b∈S) (a'' , a≡a'' , a''b∈S))
lem1 = (λ z₁ cong (\ z a , refl , z) (pathJprop (\ y _ y) z₁))
2017-11-10 15:00:00 +00:00
isequiv : isEquiv
(Σ[ a' A ] (a , a') Diag A × (a' , b) S)
((a , b) S)
backwards
isequiv y = gradLemma backwards forwards fwd-bwd bwd-fwd y
2017-11-10 15:00:00 +00:00
equi : (Σ[ a' A ] (a , a') Diag A × (a' , b) S)
(a , b) S
equi = backwards Cubical.FromStdLib., isequiv
2017-11-10 15:00:00 +00:00
ident-l : (Σ[ a' A ] (a , a') Diag A × (a' , b) S)
(a , b) S
ident-l = equivToPath equi
module _ where
private
forwards : ((a , b) S)
(Σ[ b' B ] (a , b') S × (b' , b) Diag B)
forwards proof = b , (proof , refl)
backwards : (Σ[ b' B ] (a , b') S × (b' , b) Diag B)
(a , b) S
backwards (b' , (ab'∈S , b'=b)) = subst b'=b ab'∈S
bwd-fwd : (x : (a , b) S) (backwards forwards) x x
bwd-fwd x = pathJprop (λ y _ y) x
2017-11-10 15:00:00 +00:00
fwd-bwd : (x : Σ[ b' B ] (a , b') S × (b' , b) Diag B)
(forwards backwards) x x
fwd-bwd (b' , (ab'∈S , b'≡b)) = pathJ lem0 lem1 b' (sym b'≡b) ab'∈S
where
lem0 = (λ b'' b≡b'' (ab''∈S : (a , b'') S) (forwards backwards) (b'' , ab''∈S , sym b≡b'') (b'' , ab''∈S , sym b≡b''))
lem1 = (λ ab''∈S cong (λ φ b , φ , refl) (pathJprop (λ y _ y) ab''∈S))
2017-11-10 15:00:00 +00:00
isequiv : isEquiv
(Σ[ b' B ] (a , b') S × (b' , b) Diag B)
((a , b) S)
backwards
isequiv ab∈S = gradLemma backwards forwards bwd-fwd fwd-bwd ab∈S
2017-11-10 15:00:00 +00:00
equi : (Σ[ b' B ] (a , b') S × (b' , b) Diag B)
ab S
equi = backwards Cubical.FromStdLib., isequiv
2017-11-10 15:00:00 +00:00
ident-r : (Σ[ b' B ] (a , b') S × (b' , b) Diag B)
ab S
ident-r = equivToPath equi
module _ {A B C D : Set} {S : Subset (A × B)} {R : Subset (B × C)} {Q : Subset (C × D)} (ad : A × D) where
private
a : A
a = fst ad
d : D
d = snd ad
Q⊕⟨R⊕S⟩ : Set
Q⊕⟨R⊕S⟩ = Σ[ c C ] (Σ[ b B ] (a , b) S × (b , c) R) × (c , d) Q
⟨Q⊕R⟩⊕S : Set
⟨Q⊕R⟩⊕S = Σ[ b B ] (a , b) S × (Σ[ c C ] (b , c) R × (c , d) Q)
fwd : Q⊕⟨R⊕S⟩ ⟨Q⊕R⟩⊕S
fwd (c , (b , (ab∈S , bc∈R)) , cd∈Q) = b , (ab∈S , (c , (bc∈R , cd∈Q)))
bwd : ⟨Q⊕R⟩⊕S Q⊕⟨R⊕S⟩
bwd (b , (ab∈S , (c , (bc∈R , cd∈Q)))) = c , (b , ab∈S , bc∈R) , cd∈Q
fwd-bwd : (x : ⟨Q⊕R⟩⊕S) (fwd bwd) x x
fwd-bwd x = refl
bwd-fwd : (x : Q⊕⟨R⊕S⟩) (bwd fwd) x x
bwd-fwd x = refl
isequiv : isEquiv
(Σ[ c C ] (Σ[ b B ] (a , b) S × (b , c) R) × (c , d) Q)
(Σ[ b B ] (a , b) S × (Σ[ c C ] (b , c) R × (c , d) Q))
fwd
isequiv = gradLemma fwd bwd fwd-bwd bwd-fwd
equi : (Σ[ c C ] (Σ[ b B ] (a , b) S × (b , c) R) × (c , d) Q)
(Σ[ b B ] (a , b) S × (Σ[ c C ] (b , c) R × (c , d) Q))
equi = fwd Cubical.FromStdLib., isequiv
-- assocc : Q + (R + S) ≡ (Q + R) + S
2017-11-15 20:59:00 +00:00
is-assoc : (Σ[ c C ] (Σ[ b B ] (a , b) S × (b , c) R) × (c , d) Q)
(Σ[ b B ] (a , b) S × (Σ[ c C ] (b , c) R × (c , d) Q))
2017-11-15 20:59:00 +00:00
is-assoc = equivToPath equi
Rel : Category (lsuc lzero) (lsuc lzero)
2017-11-15 20:51:41 +00:00
Rel = record
2017-11-10 15:00:00 +00:00
{ Object = Set
; Arrow = λ S R Subset (S × R)
; 𝟙 = λ {S} Diag S
; _∘_ = λ {A B C} S R λ {( a , c ) Σ[ b B ] ( (a , b) R × (b , c) S )}
2018-02-02 14:33:54 +00:00
; isCategory = record
{ assoc = funExt is-assoc
; ident = funExt ident-l , funExt ident-r
; arrow-is-set = {!!}
; univalent = {!!}
}
2017-11-10 15:00:00 +00:00
}