Permalink
Fetching contributors…
Cannot retrieve contributors at this time
542 lines (443 sloc) 26.8 KB
-- Formalization of (impredicative) set quotients
module setquot where
import bool
import sigma
import pi
import univalence
subtypeEquality (A : U) (B : A -> U) (pB : (x : A) -> prop (B x))
(s t : (x : A) * B x) : Path A s.1 t.1 -> Path (Sigma A B) s t =
trans (Path A s.1 t.1) (Path (Sigma A B) s t) rem
where
rem : Path U (Path A s.1 t.1) (Path (Sigma A B) s t) =
<i> lemSigProp A B pB s t @ -i
-- (* Propositions *)
hProp : U = (X : U) * prop X
ishinh_UU (X : U) : U = (P : hProp) -> ((X -> P.1) -> P.1)
propishinh (X : U) : prop (ishinh_UU X) =
propPi hProp (\(P : hProp) -> ((X -> P.1) -> P.1)) rem1
where
rem1 (P : hProp) : prop ((X -> P.1) -> P.1) =
propPi (X -> P.1) (\(_ : X -> P.1) -> P.1) (\(f : X -> P.1) -> P.2)
ishinh (X : U) : hProp = (ishinh_UU X,propishinh X)
hinhpr (X : U) : X -> (ishinh X).1 =
\(x : X) (P : hProp) (f : X -> P.1) -> f x
hinhuniv (X : U) (P : hProp) (f : X -> P.1) (inhX : (ishinh X).1) : P.1 =
inhX P f
hdisj (P Q : U) : hProp = ishinh (or P Q)
hdisj_in1 (P Q : U) (X : P) : (hdisj P Q).1 = hinhpr (or P Q) (inl X)
hdisj_in2 (P Q : U) (X : Q) : (hdisj P Q).1 = hinhpr (or P Q) (inr X)
-- Direct proof that logical equivalence is equiv for props
isEquivprop (A B : U) (f : A -> B) (g : B -> A) (pA : prop A) (pB : prop B) : isEquiv A B f = rem
where
rem (y : B) : isContr (fiber A B f y) = (s,t)
where
s : fiber A B f y = (g y,pB y (f (g y)))
t (w : fiber A B f y) : Path ((x : A) * Path B y (f x)) s w =
subtypeEquality A (\(x : A) -> Path B y (f x)) pb s w r1
where
pb (x : A) : (a b : Path B y (f x)) -> Path (Path B y (f x)) a b = propSet B pB y (f x)
r1 : Path A s.1 w.1 = pA s.1 w.1
equivhProp (P P' : hProp) (f : P.1 -> P'.1) (g : P'.1 -> P.1) : equiv P.1 P'.1 =
(f,isEquivprop P.1 P'.1 f g P.2 P'.2)
-- Proof of uahp using full univalence
uahp' (P P' : hProp) (f : P.1 -> P'.1) (g : P'.1 -> P.1) : Path hProp P P' =
subtypeEquality U prop propIsProp P P' rem
where
rem : Path U P.1 P'.1 = transport (<i> corrUniv P.1 P'.1 @ -i) (equivhProp P P' f g)
-- Direct proof of uahp
uahp (P P' : hProp) (f : P.1 -> P'.1) (g : P'.1 -> P.1) : Path hProp P P' =
subtypeEquality U prop propIsProp P P' rem
where
rem : Path U P.1 P'.1 = isoPath P.1 P'.1 f g s t
where s (y : P'.1) : Path P'.1 (f (g y)) y = P'.2 (f (g y)) y
t (x : P.1) : Path P.1 (g (f x)) x = P.2 (g (f x)) x
-- A short proof that hProp form a set using univalence: (this is not needed!)
propequiv (X Y : U) (H : prop Y) (f g : equiv X Y) : Path (equiv X Y) f g =
equivLemma X Y f g (<i> \(x : X) -> H (f.1 x) (g.1 x) @ i)
propidU (X Y : U) : Path U X Y -> prop Y -> prop X = substInv U prop X Y
sethProp (P P' : hProp) : prop (Path hProp P P') =
propidU (Path hProp P P') (equiv P.1 P'.1) rem (propequiv P.1 P'.1 P'.2)
where
rem1 : Path U (Path hProp P P') (Path U P.1 P'.1) = lemSigProp U prop propIsProp P P'
rem2 : Path U (Path U P.1 P'.1) (equiv P.1 P'.1) = corrUniv P.1 P'.1
rem : Path U (Path hProp P P') (equiv P.1 P'.1) =
compPath U (Path hProp P P') (Path U P.1 P'.1) (equiv P.1 P'.1) rem1 rem2
-- (* Sets *)
hsubtypes (X : U) : U = X -> hProp
carrier (X : U) (A : hsubtypes X) : U = (x : X) * (A x).1
sethsubtypes (X : U) : set (hsubtypes X) =
setPi X (\(_ : X) -> hProp) (\(_ : X) -> sethProp)
-- Definition hrel (X : UU) := X -> X -> hProp.
hrel (X : U) : U = X -> X -> hProp
iseqclass (X : U) (R : hrel X) (A : hsubtypes X) : U =
and (and (ishinh (carrier X A)).1
((x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1))
((x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1)
eqax0 (X : U) (R : hrel X) (A : hsubtypes X) (eqc : iseqclass X R A) :
(ishinh (carrier X A)).1 = eqc.1.1
eqax1 (X : U) (R : hrel X) (A : hsubtypes X) (eqc : iseqclass X R A) :
(x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1 = eqc.1.2
eqax2 (X : U) (R : hrel X) (A : hsubtypes X) (eqc : iseqclass X R A) :
(x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1 = eqc.2
propiseqclass (X : U) (R : hrel X) (A : hsubtypes X) : prop (iseqclass X R A) =
propAnd (and (ishinh (carrier X A)).1
((x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1))
((x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1)
(propAnd (ishinh (carrier X A)).1
((x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1) p1 p2)
p3
where
p1 : prop (ishinh (carrier X A)).1 = propishinh (carrier X A)
-- This proof is quite cool, but it looks ugly...
p2 (f g : (x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1) :
Path ((x1 x2 : X) -> (R x1 x2).1 -> (A x1).1 -> (A x2).1) f g =
<i> \(x1 x2 : X) (h1 : (R x1 x2).1) (h2 : (A x1).1) ->
(A x2).2 (f x1 x2 h1 h2) (g x1 x2 h1 h2) @ i
p3 (f g : (x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1) :
Path ((x1 x2 : X) -> (A x1).1 -> (A x2).1 -> (R x1 x2).1) f g =
<i> \(x1 x2 : X) (h1 : (A x1).1) (h2 : (A x2).1) ->
(R x1 x2).2 (f x1 x2 h1 h2) (g x1 x2 h1 h2) @ i
hSet : U = (X : U) * set X
isrefl (X : U) (R : hrel X) : U = (x : X) -> (R x x).1
issymm (X : U) (R : hrel X) : U = (x1 x2 : X) -> (R x1 x2).1 -> (R x2 x1).1
istrans (X : U) (R : hrel X) : U =
(x1 x2 x3 : X) -> (R x1 x2).1 -> (R x2 x3).1 -> (R x1 x3).1
ispreorder (X : U) (R : hrel X) : U = and (istrans X R) (isrefl X R)
iseqrel (X : U) (R : hrel X) : U = and (ispreorder X R) (issymm X R)
eqrel (X : U) : U = (R : hrel X) * (iseqrel X R)
eqrelrefl (X : U) (R : eqrel X) : isrefl X R.1 = R.2.1.2
eqrelsymm (X : U) (R : eqrel X) : issymm X R.1 = R.2.2
eqreltrans (X : U) (R : eqrel X) : istrans X R.1 = R.2.1.1
boolset : hSet = (bool,setbool)
setquot (X : U) (R : hrel X) : U = (A : hsubtypes X) * (iseqclass X R A)
pr1setquot (X : U) (R : hrel X) (Q : setquot X R) : hsubtypes X = Q.1
setquotpr (X : U) (R : eqrel X) (X0 : X) : setquot X R.1 = (A,((p1,p2),p3))
where
rax : isrefl X R.1 = eqrelrefl X R
sax : issymm X R.1 = eqrelsymm X R
tax : istrans X R.1 = eqreltrans X R
A : hsubtypes X = \(x : X) -> R.1 X0 x
p1 : (ishinh (carrier X A)).1 = hinhpr (carrier X A) (X0,rax X0)
p2 (x1 x2 : X) (X1 : (R.1 x1 x2).1) (X2 : (A x1).1) : (A x2).1 = tax X0 x1 x2 X2 X1
p3 (x1 x2 : X) (X1 : (A x1).1) (X2 : (A x2).1) : (R.1 x1 x2).1 = tax x1 X0 x2 (sax X0 x1 X1) X2
setquotl0 (X : U) (R : eqrel X) (c : setquot X R.1) (x : carrier X c.1) :
Path (setquot X R.1) (setquotpr X R x.1) c = subtypeEquality (hsubtypes X) (iseqclass X R.1) p (setquotpr X R x.1) c rem
where
p (A : hsubtypes X) : prop (iseqclass X R.1 A) = propiseqclass X R.1 A
rem : Path (hsubtypes X) (setquotpr X R x.1).1 c.1 = <i> \(x : X) -> (rem' x) @ i -- inlined use of funext
where rem' (a : X) : Path hProp ((setquotpr X R x.1).1 a) (c.1 a) =
uahp' ((setquotpr X R x.1).1 a) (c.1 a) l2r r2l -- This is where uahp appears
where
l2r (r : ((setquotpr X R x.1).1 a).1) : (c.1 a).1 = eqax1 X R.1 c.1 c.2 x.1 a r x.2
r2l : (c.1 a).1 -> ((setquotpr X R x.1).1 a).1 = eqax2 X R.1 c.1 c.2 x.1 a x.2
setquotunivprop (X : U) (R : eqrel X) (P : setquot X R.1 -> hProp)
(ps : (x : X) -> (P (setquotpr X R x)).1) (c : setquot X R.1) : (P c).1 = hinhuniv (carrier X c.1) (P c) f rem
where
f (x : carrier X c.1) : (P c).1 =
let e : Path (setquot X R.1) (setquotpr X R x.1) c = setquotl0 X R c x
in subst (setquot X R.1) (\(w : setquot X R.1) -> (P w).1) (setquotpr X R x.1) c e (ps x.1)
rem : (ishinh (carrier X c.1)).1 = eqax0 X R.1 c.1 c.2
setquotuniv2prop (X : U) (R : eqrel X) (P : setquot X R.1 -> setquot X R.1 -> hProp)
(ps : (x x' : X) -> (P (setquotpr X R x) (setquotpr X R x')).1) (c c' : setquot X R.1) : (P c c').1 =
setquotunivprop X R (\ (c0' : setquot X R.1) -> P c c0')
(\ (x : X) -> setquotunivprop X R (\ (c0 : setquot X R.1) -> P c0 (setquotpr X R x))
(\ (x0 : X) -> ps x0 x) c) c'
setquotuniv3prop (X : U) (R : eqrel X)
(P : setquot X R.1 -> setquot X R.1 -> setquot X R.1 -> hProp)
(ps : (x0 x1 x2 : X) -> (P (setquotpr X R x0) (setquotpr X R x1) (setquotpr X R x2)).1)
(q0 q1 q2 : setquot X R.1) : (P q0 q1 q2).1
= setquotunivprop X R (P q0 q1) (\(x2' : X) -> setquotunivprop X R (\ (q1' : setquot X R.1) -> P q0 q1' (setquotpr X R x2'))
(\(x1' : X) -> setquotunivprop X R (\(q0' : setquot X R.1) -> P q0' (setquotpr X R x1')
(setquotpr X R x2')) (\(x0' : X) -> ps x0' x1' x2') q0) q1) q2
setsetquot (X : U) (R : hrel X) : set (setquot X R) =
setSig (hsubtypes X) (\(A : hsubtypes X) -> iseqclass X R A)
sA sB
where
sA : set (hsubtypes X) = sethsubtypes X
sB (x : hsubtypes X) : set (iseqclass X R x) = propSet (iseqclass X R x) (propiseqclass X R x)
iscompsetquotpr (X : U) (R : eqrel X) (x x' : X) (a : (R.1 x x').1) :
Path (setquot X R.1) (setquotpr X R x) (setquotpr X R x') =
subtypeEquality (hsubtypes X) (iseqclass X R.1) rem1 (setquotpr X R x) (setquotpr X R x') rem2
where
rem1 (x : hsubtypes X) : prop (iseqclass X R.1 x) = propiseqclass X R.1 x
rem2 : Path (hsubtypes X) (setquotpr X R x).1 (setquotpr X R x').1 =
<i> \(x0 : X) -> rem x0 @ i
where
rem (x0 : X) : Path hProp (R.1 x x0) (R.1 x' x0) = uahp' (R.1 x x0) (R.1 x' x0) f g
where
f (r0 : (R.1 x x0).1) : (R.1 x' x0).1 =
eqreltrans X R x' x x0 (eqrelsymm X R x x' a) r0
g (r0 : (R.1 x' x0).1) : (R.1 x x0).1 =
eqreltrans X R x x' x0 a r0
weqpathsinsetquot (X : U) (R : eqrel X) (x x' : X) :
equiv (R.1 x x').1 (Path (setquot X R.1) (setquotpr X R x) (setquotpr X R x')) =
(iscompsetquotpr X R x x',rem)
where
rem : isEquiv (R.1 x x').1
(Path (setquot X R.1) (setquotpr X R x) (setquotpr X R x'))
(iscompsetquotpr X R x x') =
isEquivprop (R.1 x x').1
(Path (setquot X R.1) (setquotpr X R x) (setquotpr X R x'))
(iscompsetquotpr X R x x')
g pA pB
where g (e : Path (setquot X R.1) (setquotpr X R x) (setquotpr X R x')) :
(R.1 x x').1 = transport (<i> (rem1 @ i).1) rem
where
rem : (R.1 x' x').1 = eqrelrefl X R x'
rem2 : Path hProp (R.1 x x') (R.1 x' x') = <i> (e @ i).1 x'
rem1 : Path hProp (R.1 x' x') (R.1 x x') = <i> rem2 @ -i
pA : prop (R.1 x x').1 = (R.1 x x').2
pB : prop (Path (setquot X R.1) (setquotpr X R x) (setquotpr X R x')) =
setsetquot X R.1 (setquotpr X R x) (setquotpr X R x')
isdecprop (X : U) : U = and (prop X) (dec X)
propisdecprop (X : U): prop (isdecprop X) =
propSig (prop X) (\ (_ : prop X) -> dec X) rem1 rem2
where
rem1 : prop (prop X) = propIsProp X
rem2 : prop X -> prop (dec X) = propDec X
isdeceqif (X : U) (h : (x x' : X) -> isdecprop (Path X x x')) : discrete X =
\(x x' : X) -> (h x x').2
propEquiv (X Y : U) (w : equiv X Y) : prop X -> prop Y = subst U prop X Y rem
where
rem : Path U X Y = transport (<i> corrUniv X Y @ -i) w
isdecpropweqf (X Y : U) (w : equiv X Y) (hX : isdecprop X) : isdecprop Y = (rem1,rem2 hX.2)
where
rem1 : prop Y = propEquiv X Y w hX.1
rem2 : dec X -> dec Y = split
inl x -> inl (w.1 x)
inr nx -> inr (\(y : Y) -> nx (invEq X Y w y))
isdiscretesetquot (X : U) (R : eqrel X) (is : (x x' : X) -> isdecprop (R.1 x x').1) :
discrete (setquot X R.1) = isdeceqif (setquot X R.1) rem
where
rem : (x x' : setquot X R.1) -> isdecprop (Path (setquot X R.1) x x') =
setquotuniv2prop X R
(\(x0 x0' : setquot X R.1) -> (isdecprop (Path (setquot X R.1) x0 x0'),
propisdecprop (Path (setquot X R.1) x0 x0'))) rem'
where
rem' (x0 x0' : X) : isdecprop (Path (setquot X R.1) (setquotpr X R x0) (setquotpr X R x0')) =
isdecpropweqf (R.1 x0 x0').1 (Path (setquot X R.1) (setquotpr X R x0) (setquotpr X R x0'))
(weqpathsinsetquot X R x0 x0') (is x0 x0')
discretetobool (X : U) (h : discrete X) (x y : X) : bool = rem (h x y)
where
rem : dec (Path X x y) -> bool = split
inl _ -> true
inr _ -> false
-- The universal property of set quotients
funresprel (A B : U) (f : A -> B) (R : hrel A) : U
= (a a' : A) (r : (R a a').1) -> Path B (f a) (f a')
-- If f respects R then all x belonging to the equivalence class C are mapped into the same unique image
setquotmapcontr (A B : U) (sB : set B) (R : hrel A) (f : A -> B)
(frr : funresprel A B f R) (C : setquot A R)
: isContr ((y : B) * ((x : carrier A C.1) -> Path B y (f x.1)))
= let
T : U = (y : B) * ((x : carrier A C.1) -> Path B y (f x.1))
pT (a b : T) : Path T a b
= let
h (x : carrier A C.1) : Path B a.1 b.1 = <i> comp (<j> B) (a.2 x @ i)
[ (i = 0) -> <j> a.1
, (i = 1) -> <j> b.2 x @ -j ]
p0 : Path B a.1 b.1
= C.2.1.1 (Path B a.1 b.1, sB a.1 b.1) h
p1 : PathP (<i> (x : carrier A C.1) -> Path B (p0 @ i) (f x.1)) a.2 b.2
= let
P (b : B) : U
= (x : carrier A C.1) -> Path B b (f x.1)
pP (b : B) (s t : (P b)) : Path (P b) s t
= <i> \ (x : carrier A C.1) -> (sB b (f x.1) (s x) (t x)) @ i
in lemPropF B P pP a.1 b.1 p0 a.2 b.2
in <i> (p0 @ i, p1 @ i)
h (x : carrier A C.1) : T
= (f x.1, \ (x' : carrier A C.1) -> frr x.1 x'.1 (C.2.2 x.1 x'.1 x.2 x'.2))
y : T
= C.2.1.1 (T, pT) h
in (y, pT y)
setquotmap (A B : U) (sB : set B) (R : hrel A) (f : A -> B)
(frr : funresprel A B f R) (c : setquot A R) : B
= (setquotmapcontr A B sB R f frr c).1.1
setquotmapeq (A B : U) (sB : set B) (R : eqrel A) (f : A -> B)
(frr : funresprel A B f R.1) (x : A)
: Path B (setquotmap A B sB R.1 f frr (setquotpr A R x)) (f x)
= (setquotmapcontr A B sB R.1 f frr (setquotpr A R x)).1.2 (x, R.2.1.2 x)
opaque setquotunivprop
setquotuniversalproperty (A B : U) (sB : set B) (R : eqrel A) (f : A -> B)
(frr : funresprel A B f R.1)
: isContr ( (g : setquot A R.1 -> B)
* (Path (A -> B) (\ (a : A) -> g (setquotpr A R a)) f))
= let
G : U
= setquot A R.1 -> B
I (g : G) : U
= Path (A -> B) (\ (a : A) -> g (setquotpr A R a)) f
pI (g : G) : prop (I g)
= setPi A (\ (a : A) -> B) (\ (a : A) -> sB) (\ (a : A) -> g (setquotpr A R a)) f
g : G
= setquotmap A B sB R.1 f frr
i : I g
= <i> \ (a : A) -> setquotmapeq A B sB R f frr a @ i
eq (h : (g : G) * I g) : Path ((g : G) * I g) (g, i) h
= let
p0 : Path G g h.1
= <j> \ (x : setquot A R.1) -> let
P (y : setquot A R.1) : hProp
= (Path B (g y) (h.1 y), sB (g y) (h.1 y))
ps (a : A) : (P (setquotpr A R a)).1
= <k> comp (<_> B) ((i @ k) a)
[ (k = 0) -> <_> g (setquotpr A R a)
, (k = 1) -> <l> (h.2 @ -l) a ]
in setquotunivprop A R P ps x @ j
p1 : PathP (<i> I (p0 @ i)) i h.2
= lemPropF G I pI g h.1 p0 i h.2
in <i> (p0 @ i, p1 @ i)
in ((g, i), eq)
funresprel2 (A B C : U) (f : A -> B -> C) (R0 : hrel A) (R1 : hrel B) : U
= (a a' : A) (b b' : B) -> (R0 a a').1 -> (R1 b b').1 -> Path C (f a b) (f a' b')
hProppair (X Y : hProp) : hProp
= (and X.1 Y.1, propAnd X.1 Y.1 X.2 Y.2)
hrelpair (A B : U) (R0 : hrel A) (R1 : hrel B) (x y : and A B) : hProp
= hProppair (R0 x.1 y.1) (R1 x.2 y.2)
iseqrelpair (A B : U) (R0 : hrel A) (R1 : hrel B) (E0 : iseqrel A R0)
(E1 : iseqrel B R1) : iseqrel (and A B) (hrelpair A B R0 R1)
= let
T : U
= and A B
R : hrel T
= hrelpair A B R0 R1
rax : isrefl T R
= \ (t0 : T) -> (E0.1.2 t0.1, E1.1.2 t0.2)
sax : issymm T R
= \ (t0 t1 : T) (e : (R t0 t1).1) -> (E0.2 t0.1 t1.1 e.1, E1.2 t0.2 t1.2 e.2)
tax : istrans T R
= \ (t0 t1 t2 : T) (e0 : (R t0 t1).1) (e1 : (R t1 t2).1) ->
(E0.1.1 t0.1 t1.1 t2.1 e0.1 e1.1, E1.1.1 t0.2 t1.2 t2.2 e0.2 e1.2)
in ((tax, rax), sax)
eqrelpair (A B : U) (R0 : eqrel A) (R1 : eqrel B) : eqrel (and A B)
= (hrelpair A B R0.1 R1.1, iseqrelpair A B R0.1 R1.1 R0.2 R1.2)
hsubtypespair (A B : U) (H0 : hsubtypes A) (H1 : hsubtypes B) (x : and A B) : hProp
= hProppair (H0 x.1) (H1 x.2)
iseqclasspair (A B : U) (R0 : hrel A) (R1 : hrel B) (H0 : hsubtypes A)
(H1 : hsubtypes B) (E0 : iseqclass A R0 H0) (E1 : iseqclass B R1 H1)
: iseqclass (and A B) (hrelpair A B R0 R1) (hsubtypespair A B H0 H1)
= let
H : hsubtypes (and A B)
= hsubtypespair A B H0 H1
a (P : hProp) (f : carrier (and A B) H -> P.1) : P.1
= let
g (x0 : carrier A H0) : P.1
= let
h (x1 : carrier B H1) : P.1
= f ((x0.1, x1.1), (x0.2, x1.2))
in E1.1.1 P h
in E0.1.1 P g
b (x0 x1 : and A B) (r : (hrelpair A B R0 R1 x0 x1).1) (h0 : (H x0).1) : (H x1).1
= (E0.1.2 x0.1 x1.1 r.1 h0.1, E1.1.2 x0.2 x1.2 r.2 h0.2)
c (x0 x1 : and A B) (h0 : (H x0).1) (h1 : (H x1).1) : (hrelpair A B R0 R1 x0 x1).1
= (E0.2 x0.1 x1.1 h0.1 h1.1, E1.2 x0.2 x1.2 h0.2 h1.2)
in ((a, b), c)
setquotpair (A B : U) (R0 : hrel A) (R1 : hrel B) (q0 : setquot A R0)
(q1 : setquot B R1)
: setquot (and A B) (hrelpair A B R0 R1)
= ( hsubtypespair A B q0.1 q1.1
, iseqclasspair A B R0 R1 q0.1 q1.1 q0.2 q1.2)
setquotmap2 (A B C : U) (sC : set C) (R0 : hrel A) (R1 : hrel B)
(f : A -> B -> C) (frr : funresprel2 A B C f R0 R1) (c0 : setquot A R0)
(c1 : setquot B R1) : C
= let
f' (t : and A B) : C
= f t.1 t.2
R' : hrel (and A B)
= hrelpair A B R0 R1
frr' (s t : and A B) (r : (R' s t).1) : Path C (f' s) (f' t)
= frr s.1 t.1 s.2 t.2 r.1 r.2
c' : setquot (and A B) R'
= setquotpair A B R0 R1 c0 c1
in setquotmap (and A B) C sC R' f' frr' c'
setquotmapeq2 (A B C : U) (sC : set C) (R0 : eqrel A) (R1 : eqrel B)
(f : A -> B -> C) (frr : funresprel2 A B C f R0.1 R1.1) (x0: A) (x1 : B)
: Path C (setquotmap2 A B C sC R0.1 R1.1 f frr (setquotpr A R0 x0) (setquotpr B R1 x1)) (f x0 x1)
= let
f' (t : and A B) : C
= f t.1 t.2
R : eqrel (and A B)
= eqrelpair A B R0 R1
frr' (s t : and A B) (r : (R.1 s t).1) : Path C (f' s) (f' t)
= frr s.1 t.1 s.2 t.2 r.1 r.2
in setquotmapeq (and A B) C sC R f' frr' (x0, x1)
transparent setquotunivprop
-- The bool exercise:
R : eqrel bool = (r1,r2)
where
r1 : hrel bool = \(x y : bool) -> (Path bool x y,setbool x y)
r2 : iseqrel bool r1 = ((compPath bool,refl bool),inv bool)
bool' : U = setquot bool R.1
true' : bool' = setquotpr bool R true
false' : bool' = setquotpr bool R false
P' (t : bool') : hProp =
hdisj (Path bool' t true') (Path bool' t false')
K' (t : bool') : (P' t).1 = setquotunivprop bool R P' ps t
where
ps : (x : bool) -> (P' (setquotpr bool R x)).1 = split
false -> hdisj_in2 (Path bool' false' true')
(Path bool' false' false') (<_> false')
true -> hdisj_in1 (Path bool' true' true')
(Path bool' true' false') (<_> true')
test : (P' true').1 = hdisj_in1 (Path bool' true' true')
(Path bool' true' false') (<_> true')
test' : (P' true').1 = K' true'
-- test'' : Path (P' true').1 test test' = (P' true').2 test test'
-- These two terms are not convertible:
-- test' : Path (P' true').1 (K' true')
-- (hdisj_in1 (Path (setquot bool R.1) true' true') (Path (setquot bool R.1) true' false') (<_> true')) =
-- <_> K' true'
-- Another test:
true'neqfalse' (H : Path bool' true' false') : N0 = falseNeqTrue rem1
where
rem : Path U (Path bool true true) (Path bool false true) = <i> ((H @ i).1 true).1
rem1 : Path bool false true = comp rem (<_> true) []
test1 (x : bool') (H1 : Path bool' x true') (H2 : Path bool' x false') : N0 = true'neqfalse' rem
where
rem : Path bool' true' false' = <i> comp (<_> bool') x [(i = 0) -> H1, (i = 1) -> H2]
test2 (x : bool') (p1 : (ishinh (Path bool' x true')).1)
(p2 : (ishinh (Path bool' x false')).1) : N0 =
hinhuniv (Path bool' x true') (N0,propN0) rem p1
where
rem (H1 : Path bool' x true') : N0 =
hinhuniv (Path bool' x false') (N0,propN0)
(\(H2 : Path bool' x false') -> test1 x H1 H2) p2
-- shorthand for this big type
T (x : bool') : U = or (ishinh (Path bool' x true')).1 (ishinh (Path bool' x false')).1
-- test3 (x : bool') : prop (T x)
test3 (x : bool') : (a b : T x) -> Path (T x) a b = split
inl a' -> rem
where
rem : (b : T x) -> Path (T x) (inl a') b = split
inl b' -> <i> inl (propishinh (Path bool' x true') a' b' @ i)
inr b' -> efq (Path (T x) (inl a') (inr b')) (test2 x a' b')
inr a' -> rem
where
rem : (b : T x) -> Path (T x) (inr a') b = split
inl b' -> efq (Path (T x) (inr a') (inl b')) (test2 x b' a')
inr b' -> <i> inr (propishinh (Path bool' x false') a' b' @ i)
f (x : bool') : or (ishinh (Path bool' x true')).1 (ishinh (Path bool' x false')).1 -> bool = split
inl _ -> true
inr _ -> false
bar (x : bool') : or (Path bool' x true') (Path bool' x false') ->
or (ishinh (Path bool' x true')).1 (ishinh (Path bool' x false')).1 = split
inl p -> inl (hinhpr (Path bool' x true') p)
inr p -> inr (hinhpr (Path bool' x false') p)
-- finally the map:
foo (x : bool') (x' : (P' x).1) : bool = f x rem
where
rem : or (ishinh (Path bool' x true')).1 (ishinh (Path bool' x false')).1 =
hinhuniv (or (Path bool' x true') (Path bool' x false'))
(or (ishinh (Path bool' x true')).1 (ishinh (Path bool' x false')).1,test3 x)
(bar x) x'
-- > :n testfoo
-- NORMEVAL: true
-- Time: 0m0.490s
testfoo : bool = foo true' (K' true')
testfoo' : Path bool (foo true' (K' true')) true = <i> foo true' (K' true')
-- Tests of checking normal forms:
ntrue' : bool' = (\(x : bool) -> (PathP (<i0> bool) true x,lem8 x),((\(P : Sigma U (\(X : U) -> (a b : X) -> PathP (<i0> X) a b)) -> \(f : (Sigma bool (\(x : bool) -> PathP (<i0> bool) true x)) -> P.1) -> f ((true,<i0> true)),\(x1 x2 : bool) -> \(X1 : PathP (<i0> bool) x1 x2) -> \(X2 : PathP (<i0> bool) true x1) -> <i0> comp (<i1> bool) (X2 @ i0) [ (i0 = 0) -> <i1> true, (i0 = 1) -> <i1> X1 @ i1 ]),\(x1 x2 : bool) -> \(X1 : PathP (<i0> bool) true x1) -> \(X2 : PathP (<i0> bool) true x2) -> <i0> comp (<i1> bool) (X1 @ -i0) [ (i0 = 0) -> <i1> x1, (i0 = 1) -> <i1> X2 @ i1 ]))
nhdisj_in1 : (P Q : U) (X : P) -> (hdisj P Q).1 =
\(P Q : U) -> \(X : P) -> \(P0 : Sigma U (\(X0 : U) -> (a b : X0) -> PathP (<!0> X0) a b)) -> \(f : or P Q -> P0.1) -> f (inl X)
ntest : (P' true').1 = \(P : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> \(f : or (PathP (<!0> Sigma (bool -> (Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b))) (\(A : bool -> (Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b))) -> Sigma (Sigma ((P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> ((Sigma bool (\(x : bool) -> (A x).1)) -> P0.1) -> P0.1) (\(_ : (P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> ((Sigma bool (\(x : bool) -> (A x).1)) -> P0.1) -> P0.1) -> (x1 x2 : bool) -> (PathP (<!0> bool) x1 x2) -> ((A x1).1 -> (A x2).1))) (\(_ : Sigma ((P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> ((Sigma bool (\(x : bool) -> (A x).1)) -> P0.1) -> P0.1) (\(_ : (P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> ((Sigma bool (\(x : bool) -> (A x).1)) -> P0.1) -> P0.1) -> (x1 x2 : bool) -> (PathP (<!0> bool) x1 x2) -> ((A x1).1 -> (A x2).1))) -> (x1 x2 : bool) -> (A x1).1 -> ((A x2).1 -> (PathP (<!0> bool) x1 x2))))) ((\(x : bool) -> (PathP (<!0> bool) true x,lem8 x),((\(P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> \(f : (Sigma bool (\(x : bool) -> PathP (<!0> bool) true x)) -> P0.1) -> f ((true,<!0> true)),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) x1 x2) -> \(X2 : PathP (<!0> bool) true x1) -> <!0> comp (<!1> bool) (X2 @ !0) [ (!0 = 0) -> <!1> true, (!0 = 1) -> <!1> X1 @ !1 ]),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) true x1) -> \(X2 : PathP (<!0> bool) true x2) -> <!0> comp (<!1> bool) (X1 @ -!0) [ (!0 = 0) -> <!1> x1, (!0 = 1) -> <!1> X2 @ !1 ]))) ((\(x : bool) -> (PathP (<!0> bool) true x,lem8 x),((\(P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> \(f : (Sigma bool (\(x : bool) -> PathP (<!0> bool) true x)) -> P0.1) -> f ((true,<!0> true)),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) x1 x2) -> \(X2 : PathP (<!0> bool) true x1) -> <!0> comp (<!1> bool) (X2 @ !0) [ (!0 = 0) -> <!1> true, (!0 = 1) -> <!1> X1 @ !1 ]),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) true x1) -> \(X2 : PathP (<!0> bool) true x2) -> <!0> comp (<!1> bool) (X1 @ -!0) [ (!0 = 0) -> <!1> x1, (!0 = 1) -> <!1> X2 @ !1 ])))) PathP (<!0> Sigma (bool -> (Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b))) (\(A : bool -> (Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b))) -> Sigma (Sigma ((P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> ((Sigma bool (\(x : bool) -> (A x).1)) -> P0.1) -> P0.1) (\(_ : (P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> ((Sigma bool (\(x : bool) -> (A x).1)) -> P0.1) -> P0.1) -> (x1 x2 : bool) -> (PathP (<!0> bool) x1 x2) -> ((A x1).1 -> (A x2).1))) (\(_ : Sigma ((P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> ((Sigma bool (\(x : bool) -> (A x).1)) -> P0.1) -> P0.1) (\(_ : (P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> ((Sigma bool (\(x : bool) -> (A x).1)) -> P0.1) -> P0.1) -> (x1 x2 : bool) -> (PathP (<!0> bool) x1 x2) -> ((A x1).1 -> (A x2).1))) -> (x1 x2 : bool) -> (A x1).1 -> ((A x2).1 -> (PathP (<!0> bool) x1 x2))))) ((\(x : bool) -> (PathP (<!0> bool) true x,lem8 x),((\(P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> \(f : (Sigma bool (\(x : bool) -> PathP (<!0> bool) true x)) -> P0.1) -> f ((true,<!0> true)),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) x1 x2) -> \(X2 : PathP (<!0> bool) true x1) -> <!0> comp (<!1> bool) (X2 @ !0) [ (!0 = 0) -> <!1> true, (!0 = 1) -> <!1> X1 @ !1 ]),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) true x1) -> \(X2 : PathP (<!0> bool) true x2) -> <!0> comp (<!1> bool) (X1 @ -!0) [ (!0 = 0) -> <!1> x1, (!0 = 1) -> <!1> X2 @ !1 ]))) ((\(x : bool) -> (PathP (<!0> bool) false x,lem7 x),((\(P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> \(f : (Sigma bool (\(x : bool) -> PathP (<!0> bool) false x)) -> P0.1) -> f ((false,<!0> false)),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) x1 x2) -> \(X2 : PathP (<!0> bool) false x1) -> <!0> comp (<!1> bool) (X2 @ !0) [ (!0 = 0) -> <!1> false, (!0 = 1) -> <!1> X1 @ !1 ]),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) false x1) -> \(X2 : PathP (<!0> bool) false x2) -> <!0> comp (<!1> bool) (X1 @ -!0) [ (!0 = 0) -> <!1> x1, (!0 = 1) -> <!1> X2 @ !1 ]))) -> P.1) -> f (inl (<!0> (\(x : bool) -> (PathP (<!0> bool) true x,lem8 x),((\(P0 : Sigma U (\(X : U) -> (a b : X) -> PathP (<!0> X) a b)) -> \(f0 : (Sigma bool (\(x : bool) -> PathP (<!0> bool) true x)) -> P0.1) -> f0 ((true,<!0> true)),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) x1 x2) -> \(X2 : PathP (<!0> bool) true x1) -> <!0> comp (<!1> bool) (X2 @ !0) [ (!0 = 0) -> <!1> true, (!0 = 1) -> <!1> X1 @ !1 ]),\(x1 x2 : bool) -> \(X1 : PathP (<!0> bool) true x1) -> \(X2 : PathP (<!0> bool) true x2) -> <!0> comp (<!1> bool) (X1 @ -!0) [ (!0 = 0) -> <!1> x1, (!0 = 1) -> <!1> X2 @ !1 ]))))