[WIP] Univalence for category of homotopy sets

This commit is contained in:
Frederik Hanghøj Iversen 2018-03-19 16:27:03 +01:00
parent 2058154c65
commit 43563d1ad9

View file

@ -8,7 +8,7 @@ open import Function using (_∘_)
-- open import Cubical using (funExt ; refl ; isSet ; isProp ; _≡_ ; isEquiv ; sym ; trans ; _[_≡_] ; I ; Path ; PathP) -- open import Cubical using (funExt ; refl ; isSet ; isProp ; _≡_ ; isEquiv ; sym ; trans ; _[_≡_] ; I ; Path ; PathP)
open import Cubical hiding (_≃_) open import Cubical hiding (_≃_)
open import Cubical.Univalence using (univalence ; con ; _≃_ ; idtoeqv) open import Cubical.Univalence using (univalence ; con ; _≃_ ; idtoeqv ; ua)
open import Cubical.GradLemma open import Cubical.GradLemma
open import Cat.Category open import Cat.Category
@ -27,6 +27,13 @@ sym≃ = Equivalence.symmetry
infixl 10 _⊙_ infixl 10 _⊙_
inv-coe : { : Level} {A B : Set } {a : A}
(p : A B) coe (sym p) (coe p a) a
inv-coe = {!!}
inv-coe' : { : Level} {A B : Set } {a : A}
(p : B A) coe p (coe (sym p) a) a
inv-coe' = {!!}
module _ ( : Level) where module _ ( : Level) where
private private
open import Cubical.NType.Properties open import Cubical.NType.Properties
@ -89,11 +96,73 @@ module _ ( : Level) where
res : x y res : x y
res i = 1eq i , 2eq i res i = 1eq i , 2eq i
module _ {a b : Level} {A : Set a} {P : A Set b} where module _ {a b : Level} {A : Set a} {P : A Set b} where
postulate
lem2 : ((x : A) isProp (P x)) (p q : Σ A P) lem2 : ((x : A) isProp (P x)) (p q : Σ A P)
(p q) (proj₁ p proj₁ q) (p q) (proj₁ p proj₁ q)
lem3 : {Q : A Set b} ((x : A) P x Q x) lem2 pA p q = Eeq.fromIsomorphism iso
where
f : p q proj₁ p proj₁ q
f e i = proj₁ (e i)
g : proj₁ p proj₁ q p q
g = lemSig pA p q
ve-re : (e : p q) (g f) e e
-- QUESTION Why does `h` not satisfy the constraint here?
ve-re e i j = qq0 j , {!h!}
where
-- qq : ? [ proj₂ ((g ∘ f) e) ≡ proj₂ e ]
qq0 : proj₁ p proj₁ q
qq0 i = proj₁ (e i)
qq : (λ i P (qq0 i)) [ proj₂ p proj₂ q ]
qq = lemPropF pA qq0
h : P (qq0 j)
h = qq j
re-ve : (e : proj₁ p proj₁ q) (f g) e e
re-ve e = refl
inv : AreInverses f g
inv = record
{ verso-recto = funExt ve-re
; recto-verso = funExt re-ve
}
iso : (p q) Eqv.≅ (proj₁ p proj₁ q)
iso = f , g , inv
lem3 : {Q : A Set b} ((a : A) P a Q a)
Σ A P Σ A Q Σ A P Σ A Q
lem3 {Q} eA = res
where
P→Q : {a} P a Q a
P→Q = ua (eA _)
Q→P : {a} Q a P a
Q→P = sym P→Q
f : Σ A P Σ A Q
f (a , pA) = a , coe P→Q pA
g : Σ A Q Σ A P
g (a , qA) = a , coe Q→P qA
ve-re : (x : Σ A P) (g f) x x
ve-re x i = proj₁ x , eq i
where
eq : proj₂ ((g f) x) proj₂ x
eq = begin
proj₂ ((g f) x) ≡⟨⟩
coe Q→P (proj₂ (f x)) ≡⟨⟩
coe Q→P (coe P→Q (proj₂ x)) ≡⟨ inv-coe P→Q
proj₂ x
re-ve : (x : Σ A Q) (f g) x x
re-ve x i = proj₁ x , eq i
where
eq = begin
proj₂ ((f g) x) ≡⟨⟩
coe P→Q (coe Q→P (proj₂ x)) ≡⟨⟩
coe P→Q (coe (sym P→Q) (proj₂ x)) ≡⟨ inv-coe' P→Q
proj₂ x
inv : AreInverses f g
inv = record
{ verso-recto = funExt ve-re
; recto-verso = funExt re-ve
}
iso : Σ A P Eqv.≅ Σ A Q
iso = f , g , inv
res : Σ A P Σ A Q
res = Eeq.fromIsomorphism iso
module _ {a b : Level} {A : Set a} {B : Set b} where module _ {a b : Level} {A : Set a} {B : Set b} where
postulate postulate
@ -136,7 +205,7 @@ module _ ( : Level) where
res = _≃_.isEqv t res = _≃_.isEqv t
module _ {hA hB : hSet {}} where module _ {hA hB : hSet {}} where
univalent : isEquiv (hA hB) (hA hB) (id-to-iso (λ {A} {B} isIdentity {A} {B}) hA hB) univalent : isEquiv (hA hB) (hA hB) (id-to-iso (λ {A} {B} isIdentity {A} {B}) hA hB)
univalent = let k = _≃_.isEqv (sym≃ conclusion) in {!!} univalent = let k = _≃_.isEqv (sym≃ conclusion) in {!k!}
SetsIsCategory : IsCategory SetsRaw SetsIsCategory : IsCategory SetsRaw
IsCategory.isAssociative SetsIsCategory = refl IsCategory.isAssociative SetsIsCategory = refl