545 lines
20 KiB
Agda
545 lines
20 KiB
Agda
{-# OPTIONS --cubical #-}
|
||
module Cat.Equivalence where
|
||
|
||
open import Cubical.Primitives
|
||
open import Cubical.FromStdLib renaming (ℓ-max to _⊔_)
|
||
open import Cubical.PathPrelude hiding (inverse)
|
||
open import Cubical.PathPrelude using (isEquiv ; isContr ; fiber) public
|
||
open import Cubical.GradLemma hiding (isoToPath)
|
||
|
||
open import Cat.Prelude using
|
||
( lemPropF ; setPi ; lemSig ; propSet
|
||
; Preorder ; equalityIsEquivalence ; propSig ; id-coe
|
||
; Setoid ; _$_ ; propPi )
|
||
|
||
import Cubical.Univalence as U
|
||
|
||
module _ {ℓ : Level} {A B : Set ℓ} where
|
||
open Cubical.PathPrelude
|
||
ua : A ≃ B → A ≡ B
|
||
ua (f , isEqv) = U.ua (U.con f isEqv)
|
||
|
||
module _ {ℓa ℓb : Level} where
|
||
private
|
||
ℓ = ℓa ⊔ ℓb
|
||
|
||
module _ {A : Set ℓa} {B : Set ℓb} where
|
||
-- Quasi-inverse in [HoTT] §2.4.6
|
||
-- FIXME Maybe rename?
|
||
AreInverses : (f : A → B) (g : B → A) → Set ℓ
|
||
AreInverses f g = g ∘ f ≡ idFun A × f ∘ g ≡ idFun B
|
||
|
||
module AreInverses {f : A → B} {g : B → A}
|
||
(inv : AreInverses f g) where
|
||
open Σ inv renaming (fst to verso-recto ; snd to recto-verso) public
|
||
obverse = f
|
||
reverse = g
|
||
inverse = reverse
|
||
|
||
Isomorphism : (f : A → B) → Set _
|
||
Isomorphism f = Σ (B → A) λ g → AreInverses f g
|
||
|
||
_≅_ : Set ℓa → Set ℓb → Set _
|
||
A ≅ B = Σ (A → B) Isomorphism
|
||
|
||
symIso : ∀ {ℓa ℓb} {A : Set ℓa}{B : Set ℓb} → A ≅ B → B ≅ A
|
||
symIso (f , g , p , q)= g , f , q , p
|
||
|
||
module _ {ℓa ℓb ℓc} {A : Set ℓa} {B : Set ℓb} (sB : isSet B) {Q : B → Set ℓc} (f : A → B) where
|
||
|
||
Σ-fst-map : Σ A (\ a → Q (f a)) → Σ B Q
|
||
Σ-fst-map (x , q) = f x , q
|
||
|
||
isoSigFst : Isomorphism f → Σ A (Q ∘ f) ≅ Σ B Q
|
||
isoSigFst (g , g-f , f-g) = Σ-fst-map
|
||
, (\ { (b , q) → g b , transp (\ i → Q (f-g (~ i) b)) q })
|
||
, funExt (\ { (a , q) → Cat.Prelude.Σ≡ (\ i → g-f i a)
|
||
let r = (transp-iso' ((λ i → Q (f-g (i) (f a)))) q) in
|
||
transp (\ i → PathP (\ j → Q (sB _ _ (λ j₁ → f-g j₁ (f a)) (λ j₁ → f (g-f j₁ a)) i j)) (transp (λ i₁ → Q (f-g (~ i₁) (f a))) q) q) r })
|
||
, funExt (\ { (b , q) → Cat.Prelude.Σ≡ (\ i → f-g i b) (transp-iso' (λ i → Q (f-g i b)) q)})
|
||
|
||
|
||
module _ {ℓ : Level} {A B : Set ℓ} {f : A → B}
|
||
(g : B → A) (s : {A B : Set ℓ} → isSet (A → B)) where
|
||
|
||
propAreInverses : isProp (AreInverses {A = A} {B} f g)
|
||
propAreInverses x y i = ve-re , re-ve
|
||
where
|
||
ve-re : g ∘ f ≡ idFun A
|
||
ve-re = s (g ∘ f) (idFun A) (fst x) (fst y) i
|
||
re-ve : f ∘ g ≡ idFun B
|
||
re-ve = s (f ∘ g) (idFun B) (snd x) (snd y) i
|
||
|
||
module _ {ℓ : Level} {A B : Set ℓ} (f : A → B)
|
||
(sA : isSet A) (sB : isSet B) where
|
||
|
||
propIsIso : isProp (Isomorphism f)
|
||
propIsIso = res
|
||
where
|
||
module _ (x y : Isomorphism f) where
|
||
module x = Σ x renaming (fst to inverse ; snd to areInverses)
|
||
module y = Σ y renaming (fst to inverse ; snd to areInverses)
|
||
module xA = AreInverses {f = f} {x.inverse} x.areInverses
|
||
module yA = AreInverses {f = f} {y.inverse} y.areInverses
|
||
-- I had a lot of difficulty using the corresponding proof where
|
||
-- AreInverses is defined. This is sadly a bit anti-modular. The
|
||
-- reason for my troubles is probably related to the type of objects
|
||
-- being hSet's rather than sets.
|
||
p : ∀ {f} g → isProp (AreInverses {A = A} {B} f g)
|
||
p {f} g xx yy i = ve-re , re-ve
|
||
where
|
||
module xxA = AreInverses {f = f} {g} xx
|
||
module yyA = AreInverses {f = f} {g} yy
|
||
setPiB : ∀ {X : Set ℓ} → isSet (X → B)
|
||
setPiB = setPi (λ _ → sB)
|
||
setPiA : ∀ {X : Set ℓ} → isSet (X → A)
|
||
setPiA = setPi (λ _ → sA)
|
||
ve-re : g ∘ f ≡ idFun _
|
||
ve-re = setPiA _ _ xxA.verso-recto yyA.verso-recto i
|
||
re-ve : f ∘ g ≡ idFun _
|
||
re-ve = setPiB _ _ xxA.recto-verso yyA.recto-verso i
|
||
1eq : x.inverse ≡ y.inverse
|
||
1eq = begin
|
||
x.inverse ≡⟨⟩
|
||
x.inverse ∘ idFun _ ≡⟨ cong (λ φ → x.inverse ∘ φ) (sym yA.recto-verso) ⟩
|
||
x.inverse ∘ (f ∘ y.inverse) ≡⟨⟩
|
||
(x.inverse ∘ f) ∘ y.inverse ≡⟨ cong (λ φ → φ ∘ y.inverse) xA.verso-recto ⟩
|
||
idFun _ ∘ y.inverse ≡⟨⟩
|
||
y.inverse ∎
|
||
2eq : (λ i → AreInverses f (1eq i)) [ x.areInverses ≡ y.areInverses ]
|
||
2eq = lemPropF p 1eq
|
||
res : x ≡ y
|
||
res i = 1eq i , 2eq i
|
||
|
||
-- In HoTT they generalize an equivalence to have the following 3 properties:
|
||
module _ {ℓa ℓb ℓ : Level} (A : Set ℓa) (B : Set ℓb) where
|
||
record Equiv (iseqv : (A → B) → Set ℓ) : Set (ℓa ⊔ ℓb ⊔ ℓ) where
|
||
field
|
||
fromIso : {f : A → B} → Isomorphism f → iseqv f
|
||
toIso : {f : A → B} → iseqv f → Isomorphism f
|
||
propIsEquiv : (f : A → B) → isProp (iseqv f)
|
||
|
||
-- You're alerady assuming here that we don't need eta-equality on the
|
||
-- equivalence!
|
||
_~_ : Set ℓa → Set ℓb → Set _
|
||
A ~ B = Σ _ iseqv
|
||
|
||
inverse-from-to-iso : ∀ {f} (x : _) → (fromIso {f} ∘ toIso {f}) x ≡ x
|
||
inverse-from-to-iso x = begin
|
||
(fromIso ∘ toIso) x ≡⟨⟩
|
||
fromIso (toIso x) ≡⟨ propIsEquiv _ (fromIso (toIso x)) x ⟩
|
||
x ∎
|
||
|
||
-- | The other inverse law does not hold in general, it does hold, however,
|
||
-- | if `A` and `B` are sets.
|
||
module _ (sA : isSet A) (sB : isSet B) where
|
||
module _ {f : A → B} where
|
||
module _ (iso-x iso-y : Isomorphism f) where
|
||
open Σ iso-x renaming (fst to x ; snd to inv-x)
|
||
open Σ iso-y renaming (fst to y ; snd to inv-y)
|
||
|
||
fx≡fy : x ≡ y
|
||
fx≡fy = begin
|
||
x ≡⟨ cong (λ φ → x ∘ φ) (sym (snd inv-y)) ⟩
|
||
x ∘ (f ∘ y) ≡⟨⟩
|
||
(x ∘ f) ∘ y ≡⟨ cong (λ φ → φ ∘ y) (fst inv-x) ⟩
|
||
y ∎
|
||
|
||
propInv : ∀ g → isProp (AreInverses f g)
|
||
propInv g t u = λ i → a i , b i
|
||
where
|
||
a : (fst t) ≡ (fst u)
|
||
a i = funExt hh
|
||
where
|
||
hh : ∀ a → (g ∘ f) a ≡ a
|
||
hh a = sA ((g ∘ f) a) a (λ i → (fst t) i a) (λ i → (fst u) i a) i
|
||
b : (snd t) ≡ (snd u)
|
||
b i = funExt hh
|
||
where
|
||
hh : ∀ b → (f ∘ g) b ≡ b
|
||
hh b = sB _ _ (λ i → snd t i b) (λ i → snd u i b) i
|
||
|
||
inx≡iny : (λ i → AreInverses f (fx≡fy i)) [ inv-x ≡ inv-y ]
|
||
inx≡iny = lemPropF propInv fx≡fy
|
||
|
||
propIso : iso-x ≡ iso-y
|
||
propIso i = fx≡fy i , inx≡iny i
|
||
|
||
module _ (iso : Isomorphism f) where
|
||
inverse-to-from-iso : (toIso {f} ∘ fromIso {f}) iso ≡ iso
|
||
inverse-to-from-iso = begin
|
||
(toIso ∘ fromIso) iso ≡⟨⟩
|
||
toIso (fromIso iso) ≡⟨ propIso _ _ ⟩
|
||
iso ∎
|
||
|
||
fromIsomorphism : A ≅ B → A ~ B
|
||
fromIsomorphism (f , iso) = f , fromIso iso
|
||
|
||
toIsomorphism : A ~ B → A ≅ B
|
||
toIsomorphism (f , eqv) = f , toIso eqv
|
||
|
||
module _ {ℓa ℓb : Level} (A : Set ℓa) (B : Set ℓb) where
|
||
-- A wrapper around PathPrelude.≃
|
||
open Cubical.PathPrelude using (_≃_)
|
||
private
|
||
module _ {obverse : A → B} (e : isEquiv A B obverse) where
|
||
inverse : B → A
|
||
inverse b = fst (fst (e b))
|
||
|
||
reverse : B → A
|
||
reverse = inverse
|
||
|
||
areInverses : AreInverses obverse inverse
|
||
areInverses = funExt verso-recto , funExt recto-verso
|
||
where
|
||
recto-verso : ∀ b → (obverse ∘ inverse) b ≡ b
|
||
recto-verso b = begin
|
||
(obverse ∘ inverse) b ≡⟨ sym (μ b) ⟩
|
||
b ∎
|
||
where
|
||
μ : (b : B) → b ≡ obverse (inverse b)
|
||
μ b = snd (fst (e b))
|
||
verso-recto : ∀ a → (inverse ∘ obverse) a ≡ a
|
||
verso-recto a = begin
|
||
(inverse ∘ obverse) a ≡⟨ sym h ⟩
|
||
a' ≡⟨ u' ⟩
|
||
a ∎
|
||
where
|
||
c : isContr (fiber obverse (obverse a))
|
||
c = e (obverse a)
|
||
fbr : fiber obverse (obverse a)
|
||
fbr = fst c
|
||
a' : A
|
||
a' = fst fbr
|
||
allC : (y : fiber obverse (obverse a)) → fbr ≡ y
|
||
allC = snd c
|
||
k : fbr ≡ (inverse (obverse a), _)
|
||
k = allC (inverse (obverse a) , sym (recto-verso (obverse a)))
|
||
h : a' ≡ inverse (obverse a)
|
||
h i = fst (k i)
|
||
u : fbr ≡ (a , refl)
|
||
u = allC (a , refl)
|
||
u' : a' ≡ a
|
||
u' i = fst (u i)
|
||
|
||
iso : Isomorphism obverse
|
||
iso = reverse , areInverses
|
||
|
||
toIsomorphism : {f : A → B} → isEquiv A B f → Isomorphism f
|
||
toIsomorphism = iso
|
||
|
||
≃isEquiv : Equiv A B (isEquiv A B)
|
||
Equiv.fromIso ≃isEquiv {f} (f~ , iso) = gradLemma f f~ rv vr
|
||
where
|
||
rv : (b : B) → _ ≡ b
|
||
rv b i = snd iso i b
|
||
vr : (a : A) → _ ≡ a
|
||
vr a i = fst iso i a
|
||
Equiv.toIso ≃isEquiv = toIsomorphism
|
||
Equiv.propIsEquiv ≃isEquiv = P.propIsEquiv
|
||
where
|
||
import Cubical.NType.Properties as P
|
||
|
||
open Equiv ≃isEquiv public
|
||
|
||
module _ {ℓa ℓb : Level} {A : Set ℓa} {B : Set ℓb} where
|
||
open Cubical.PathPrelude using (_≃_)
|
||
|
||
module _ {ℓc : Level} {C : Set ℓc} {f : A → B} {g : B → C} where
|
||
|
||
composeIsomorphism : Isomorphism f → Isomorphism g → Isomorphism (g ∘ f)
|
||
composeIsomorphism a b = f~ ∘ g~ , inv
|
||
where
|
||
open Σ a renaming (fst to f~ ; snd to inv-a)
|
||
open Σ b renaming (fst to g~ ; snd to inv-b)
|
||
inv : AreInverses (g ∘ f) (f~ ∘ g~)
|
||
inv = record
|
||
{ fst = begin
|
||
(f~ ∘ g~) ∘ (g ∘ f) ≡⟨⟩
|
||
f~ ∘ (g~ ∘ g) ∘ f ≡⟨ cong (λ φ → f~ ∘ φ ∘ f) (fst inv-b) ⟩
|
||
f~ ∘ idFun _ ∘ f ≡⟨⟩
|
||
f~ ∘ f ≡⟨ (fst inv-a) ⟩
|
||
idFun A ∎
|
||
; snd = begin
|
||
(g ∘ f) ∘ (f~ ∘ g~) ≡⟨⟩
|
||
g ∘ (f ∘ f~) ∘ g~ ≡⟨ cong (λ φ → g ∘ φ ∘ g~) (snd inv-a) ⟩
|
||
g ∘ g~ ≡⟨ (snd inv-b) ⟩
|
||
idFun C ∎
|
||
}
|
||
|
||
composeIsEquiv : isEquiv A B f → isEquiv B C g → isEquiv A C (g ∘ f)
|
||
composeIsEquiv a b = fromIso A C (composeIsomorphism a' b')
|
||
where
|
||
a' = toIso A B a
|
||
b' = toIso B C b
|
||
|
||
composeIso : {ℓc : Level} {C : Set ℓc} → (A ≅ B) → (B ≅ C) → A ≅ C
|
||
composeIso {C = C} (f , iso-f) (g , iso-g) = g ∘ f , composeIsomorphism iso-f iso-g
|
||
|
||
symmetryIso : (A ≅ B) → B ≅ A
|
||
symmetryIso (inverse , obverse , verso-recto , recto-verso)
|
||
= obverse
|
||
, inverse
|
||
, recto-verso
|
||
, verso-recto
|
||
|
||
-- Gives the quasi inverse from an equivalence.
|
||
module Equivalence (e : A ≃ B) where
|
||
compose : {ℓc : Level} {C : Set ℓc} → (B ≃ C) → A ≃ C
|
||
compose e' = fromIsomorphism _ _ (composeIso (toIsomorphism _ _ e) (toIsomorphism _ _ e'))
|
||
|
||
symmetry : B ≃ A
|
||
symmetry = fromIsomorphism _ _ (symmetryIso (toIsomorphism _ _ e))
|
||
|
||
preorder≅ : (ℓ : Level) → Preorder _ _ _
|
||
preorder≅ ℓ = record
|
||
{ Carrier = Set ℓ ; _≈_ = _≡_ ; _∼_ = _≅_
|
||
; isPreorder = record
|
||
{ isEquivalence = equalityIsEquivalence
|
||
; reflexive = λ p
|
||
→ coe p
|
||
, coe (sym p)
|
||
, funExt (λ x → inv-coe p)
|
||
, funExt (λ x → inv-coe' p)
|
||
; trans = composeIso
|
||
}
|
||
}
|
||
where
|
||
module _ {ℓ : Level} {A B : Set ℓ} {a : A} where
|
||
inv-coe : (p : A ≡ B) → coe (sym p) (coe p a) ≡ a
|
||
inv-coe p =
|
||
let
|
||
D : (y : Set ℓ) → _ ≡ y → Set _
|
||
D _ q = coe (sym q) (coe q a) ≡ a
|
||
d : D A refl
|
||
d = begin
|
||
coe (sym refl) (coe refl a) ≡⟨⟩
|
||
coe refl (coe refl a) ≡⟨ id-coe ⟩
|
||
coe refl a ≡⟨ id-coe ⟩
|
||
a ∎
|
||
in pathJ D d B p
|
||
inv-coe' : (p : B ≡ A) → coe p (coe (sym p) a) ≡ a
|
||
inv-coe' p =
|
||
let
|
||
D : (y : Set ℓ) → _ ≡ y → Set _
|
||
D _ q = coe (sym q) (coe q a) ≡ a
|
||
k : coe p (coe (sym p) a) ≡ a
|
||
k = pathJ D (trans id-coe id-coe) B (sym p)
|
||
in k
|
||
|
||
setoid≅ : (ℓ : Level) → Setoid _ _
|
||
setoid≅ ℓ = record
|
||
{ Carrier = Set ℓ
|
||
; _≈_ = _≅_
|
||
; isEquivalence = record
|
||
{ refl = idFun _ , idFun _ , (funExt λ _ → refl) , (funExt λ _ → refl)
|
||
; sym = symmetryIso
|
||
; trans = composeIso
|
||
}
|
||
}
|
||
|
||
setoid≃ : (ℓ : Level) → Setoid _ _
|
||
setoid≃ ℓ = record
|
||
{ Carrier = Set ℓ
|
||
; _≈_ = _≃_
|
||
; isEquivalence = record
|
||
{ refl = idEquiv
|
||
; sym = Equivalence.symmetry
|
||
; trans = λ x x₁ → Equivalence.compose x x₁
|
||
}
|
||
}
|
||
|
||
-- If the second component of a pair is propositional, then equality of such
|
||
-- pairs is equivalent to equality of their first components.
|
||
module _ {ℓa ℓb : Level} {A : Set ℓa} {P : A → Set ℓb} where
|
||
equivSigProp : ((x : A) → isProp (P x)) → {p q : Σ A P}
|
||
→ (p ≡ q) ≃ (fst p ≡ fst q)
|
||
equivSigProp pA {p} {q} = fromIsomorphism _ _ iso
|
||
where
|
||
f : ∀ {p q} → p ≡ q → fst p ≡ fst q
|
||
f = cong fst
|
||
g : ∀ {p q} → fst p ≡ fst q → p ≡ q
|
||
g = lemSig pA _ _
|
||
ve-re : (e : p ≡ q) → (g ∘ f) e ≡ e
|
||
ve-re = pathJ (\ q (e : p ≡ q) → (g ∘ f) e ≡ e)
|
||
(\ i j → p .fst , propSet (pA (p .fst)) (p .snd) (p .snd) (λ i → (g {p} {p} ∘ f) (λ i₁ → p) i .snd) (λ i → p .snd) i j ) q
|
||
re-ve : (e : fst p ≡ fst q) → (f {p} {q} ∘ g {p} {q}) e ≡ e
|
||
re-ve e = refl
|
||
inv : AreInverses (f {p} {q}) (g {p} {q})
|
||
inv = funExt ve-re , funExt re-ve
|
||
iso : (p ≡ q) ≅ (fst p ≡ fst q)
|
||
iso = f , g , inv
|
||
|
||
module _ {ℓ : Level} {A B : Set ℓ} where
|
||
isoToPath : (A ≅ B) → (A ≡ B)
|
||
isoToPath = ua ∘ fromIsomorphism _ _
|
||
|
||
univalence : (A ≡ B) ≃ (A ≃ B)
|
||
univalence = Equivalence.compose u' aux
|
||
where
|
||
module _ {ℓa ℓb : Level} {A : Set ℓa} {B : Set ℓb} where
|
||
deEta : A ≃ B → A U.≃ B
|
||
deEta (a , b) = U.con a b
|
||
doEta : A U.≃ B → A ≃ B
|
||
doEta (U.con eqv isEqv) = eqv , isEqv
|
||
u : (A ≡ B) U.≃ (A U.≃ B)
|
||
u = U.univalence
|
||
u' : (A ≡ B) ≃ (A U.≃ B)
|
||
u' = doEta u
|
||
aux : (A U.≃ B) ≃ (A ≃ B)
|
||
aux = fromIsomorphism _ _ (doEta , deEta , funExt (λ{ (U.con _ _) → refl}) , refl)
|
||
|
||
-- Equivalence is equivalent to isomorphism when the equivalence (resp.
|
||
-- isomorphism) acts on sets.
|
||
module _ (sA : isSet A) (sB : isSet B) where
|
||
equiv≃iso : (f : A → B) → isEquiv A B f ≃ Isomorphism f
|
||
equiv≃iso f =
|
||
let
|
||
obv : isEquiv A B f → Isomorphism f
|
||
obv = toIso A B
|
||
inv : Isomorphism f → isEquiv A B f
|
||
inv = fromIso A B
|
||
re-ve : (x : isEquiv A B f) → (inv ∘ obv) x ≡ x
|
||
re-ve = inverse-from-to-iso A B
|
||
ve-re : (x : Isomorphism f) → (obv ∘ inv) x ≡ x
|
||
ve-re = inverse-to-from-iso A B sA sB
|
||
iso : isEquiv A B f ≅ Isomorphism f
|
||
iso = obv , inv , funExt re-ve , funExt ve-re
|
||
in fromIsomorphism _ _ iso
|
||
|
||
-- A few results that I have not generalized to work with both the eta and no-eta variable of ≃
|
||
module _ {ℓa ℓb : Level} {A : Set ℓa} {P : A → Set ℓb} where
|
||
-- Equality on sigma's whose second component is a proposition is equivalent
|
||
-- to equality on their first components.
|
||
equivPropSig : ((x : A) → isProp (P x)) → (p q : Σ A P)
|
||
→ (p ≡ q) ≃ (fst p ≡ fst q)
|
||
equivPropSig pA p q = fromIsomorphism _ _ iso
|
||
where
|
||
f : ∀ {p q} → p ≡ q → fst p ≡ fst q
|
||
f = cong fst
|
||
g : ∀ {p q} → fst p ≡ fst q → p ≡ q
|
||
g {p} {q} = lemSig pA p q
|
||
ve-re : (e : p ≡ q) → (g ∘ f) e ≡ e
|
||
ve-re = pathJ (\ q (e : p ≡ q) → (g ∘ f) e ≡ e)
|
||
(\ i j → p .fst , propSet (pA (p .fst)) (p .snd) (p .snd) (λ i → (g {p} {p} ∘ f) (λ i₁ → p) i .snd) (λ i → p .snd) i j ) q
|
||
re-ve : (e : fst p ≡ fst q) → (f {p} {q} ∘ g {p} {q}) e ≡ e
|
||
re-ve e = refl
|
||
inv : AreInverses (f {p} {q}) (g {p} {q})
|
||
inv = funExt ve-re , funExt re-ve
|
||
iso : (p ≡ q) ≅ (fst p ≡ fst q)
|
||
iso = f , g , inv
|
||
|
||
-- Sigma that are equivalent on all points in the second projection are
|
||
-- equivalent.
|
||
equivSigSnd : ∀ {ℓc} {Q : A → Set (ℓc ⊔ ℓb)}
|
||
→ ((a : A) → P a ≃ Q a) → Σ A P ≃ Σ A Q
|
||
equivSigSnd {Q = Q} eA = res
|
||
where
|
||
f : Σ A P → Σ A Q
|
||
f (a , pA) = a , fst (eA a) pA
|
||
g : Σ A Q → Σ A P
|
||
g (a , qA) = a , g' qA
|
||
where
|
||
k : Isomorphism _
|
||
k = toIso _ _ (snd (eA a))
|
||
open Σ k renaming (fst to g')
|
||
ve-re : (x : Σ A P) → (g ∘ f) x ≡ x
|
||
ve-re x i = fst x , eq i
|
||
where
|
||
eq : snd ((g ∘ f) x) ≡ snd x
|
||
eq = begin
|
||
snd ((g ∘ f) x) ≡⟨⟩
|
||
snd (g (f (a , pA))) ≡⟨⟩
|
||
g' (fst (eA a) pA) ≡⟨ lem ⟩
|
||
pA ∎
|
||
where
|
||
open Σ x renaming (fst to a ; snd to pA)
|
||
k : Isomorphism _
|
||
k = toIso _ _ (snd (eA a))
|
||
open Σ k renaming (fst to g' ; snd to inv)
|
||
lem : (g' ∘ (fst (eA a))) pA ≡ pA
|
||
lem i = fst inv i pA
|
||
re-ve : (x : Σ A Q) → (f ∘ g) x ≡ x
|
||
re-ve x i = fst x , eq i
|
||
where
|
||
open Σ x renaming (fst to a ; snd to qA)
|
||
eq = begin
|
||
snd ((f ∘ g) x) ≡⟨⟩
|
||
fst (eA a) (g' qA) ≡⟨ (λ i → snd inv i qA) ⟩
|
||
qA ∎
|
||
where
|
||
k : Isomorphism _
|
||
k = toIso _ _ (snd (eA a))
|
||
open Σ k renaming (fst to g' ; snd to inv)
|
||
inv : AreInverses f g
|
||
inv = funExt ve-re , funExt re-ve
|
||
iso : Σ A P ≅ Σ A Q
|
||
iso = f , g , inv
|
||
res : Σ A P ≃ Σ A Q
|
||
res = fromIsomorphism _ _ iso
|
||
|
||
module _ {ℓa ℓb : Level} {A : Set ℓa} {B : Set ℓb} where
|
||
-- Equivalence is equivalent to isomorphism when the domain and codomain of
|
||
-- the equivalence is a set.
|
||
equivSetIso : isSet A → isSet B → (f : A → B)
|
||
→ isEquiv A B f ≃ Isomorphism f
|
||
equivSetIso sA sB f =
|
||
let
|
||
obv : isEquiv A B f → Isomorphism f
|
||
obv = toIso A B
|
||
inv : Isomorphism f → isEquiv A B f
|
||
inv = fromIso A B
|
||
re-ve : (x : isEquiv A B f) → (inv ∘ obv) x ≡ x
|
||
re-ve = inverse-from-to-iso A B
|
||
ve-re : (x : Isomorphism f) → (obv ∘ inv) x ≡ x
|
||
ve-re = inverse-to-from-iso A B sA sB
|
||
iso : isEquiv A B f ≅ Isomorphism f
|
||
iso = obv , inv , funExt re-ve , funExt ve-re
|
||
in fromIsomorphism _ _ iso
|
||
|
||
module _ {ℓa ℓb : Level} {A : Set ℓa} {P : A → Set ℓb} where
|
||
-- Equivalence of pairs whose first components are identitical can be obtained
|
||
-- from an equivalence of their seecond components.
|
||
equivSig : {ℓc : Level} {Q : A → Set ℓc}
|
||
→ ((a : A) → P a ≃ Q a) → Σ A P ≃ Σ A Q
|
||
equivSig {Q = Q} eA = res
|
||
where
|
||
P≅Q : ∀ {a} → P a ≅ Q a
|
||
P≅Q {a} = toIsomorphism _ _ (eA a)
|
||
f : Σ A P → Σ A Q
|
||
f (a , pA) = a , fst P≅Q pA
|
||
g : Σ A Q → Σ A P
|
||
g (a , qA) = a , fst (snd P≅Q) qA
|
||
ve-re : (x : Σ A P) → (g ∘ f) x ≡ x
|
||
ve-re (a , pA) i = a , eq i
|
||
where
|
||
eq : snd ((g ∘ f) (a , pA)) ≡ pA
|
||
eq = begin
|
||
snd ((g ∘ f) (a , pA)) ≡⟨⟩
|
||
snd (g (f (a , pA))) ≡⟨⟩
|
||
g' (fst (eA a) pA) ≡⟨ lem ⟩
|
||
pA ∎
|
||
where
|
||
open Σ (snd P≅Q) renaming (fst to g' ; snd to inv)
|
||
-- anti-funExt
|
||
lem : (g' ∘ (fst (eA a))) pA ≡ pA
|
||
lem = cong (_$ pA) (fst (snd (snd P≅Q)))
|
||
re-ve : (x : Σ A Q) → (f ∘ g) x ≡ x
|
||
re-ve x i = fst x , eq i
|
||
where
|
||
open Σ x renaming (fst to a ; snd to qA)
|
||
eq = begin
|
||
snd ((f ∘ g) x) ≡⟨⟩
|
||
fst (eA a) (g' qA) ≡⟨ (λ i → snd inv i qA) ⟩
|
||
qA ∎
|
||
where
|
||
k : Isomorphism _
|
||
k = toIso _ _ (snd (eA a))
|
||
open Σ k renaming (fst to g' ; snd to inv)
|
||
inv : AreInverses f g
|
||
inv = funExt ve-re , funExt re-ve
|
||
iso : Σ A P ≅ Σ A Q
|
||
iso = f , g , inv
|
||
res : Σ A P ≃ Σ A Q
|
||
res = fromIsomorphism _ _ iso
|