Compare commits
167 Commits
Andrea Vezzosi
|
|
@ -1 +1 @@
|
|||
references/
|
||||
html/
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
[submodule "libs/cubical"]
|
||||
path = libs/cubical
|
||||
url = git@github.com:fredefox/cubical.git
|
||||
url = git@github.com:Saizan/cubical-demo.git
|
||||
[submodule "libs/agda-stdlib"]
|
||||
path = libs/agda-stdlib
|
||||
url = git@github.com:agda/agda-stdlib.git
|
||||
|
|
|
|||
15
BACKLOG.md
15
BACKLOG.md
|
|
@ -1,21 +1,12 @@
|
|||
Backlog
|
||||
=======
|
||||
|
||||
Prove postulates in `Cat.Wishlist`:
|
||||
* `ntypeCommulative : n ≤ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A`
|
||||
|
||||
Prove that these two formulations of univalence are equivalent:
|
||||
|
||||
∀ A B → isEquiv (A ≡ B) (A ≅ B) (id-to-iso A B)
|
||||
∀ A → isContr (Σ[ X ∈ Object ] A ≅ X)
|
||||
|
||||
Prove univalence for the category of
|
||||
* the opposite category
|
||||
* functors and natural transformations
|
||||
|
||||
Prove:
|
||||
* `isProp (Product ...)`
|
||||
* `isProp (HasProducts ...)`
|
||||
In AreInverses, dont use the "point-free" version. I.e.:
|
||||
|
||||
`∀ x → f x ≡ g x` rather than `f ≡ g`
|
||||
|
||||
Ideas for future work
|
||||
---------------------
|
||||
|
|
|
|||
43
CHANGELOG.md
43
CHANGELOG.md
|
|
@ -1,6 +1,39 @@
|
|||
Changelog
|
||||
Change log
|
||||
=========
|
||||
|
||||
Version 1.6.0
|
||||
-------------
|
||||
|
||||
This version mainly contains changes to the report.
|
||||
|
||||
This is the version I submit for my MSc..
|
||||
|
||||
Version 1.5.0
|
||||
-------------
|
||||
Prove postulates in `Cat.Wishlist`:
|
||||
|
||||
* `ntypeCommulative : n ≤ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A`
|
||||
|
||||
Prove that these two formulations of univalence are equivalent:
|
||||
|
||||
∀ A B → isEquiv (A ≡ B) (A ≅ B) (id-to-iso A B)
|
||||
∀ A → isContr (Σ[ X ∈ Object ] A ≅ X)
|
||||
|
||||
Prove univalence for the category of...
|
||||
|
||||
* the opposite category
|
||||
* sets
|
||||
* "pair" category
|
||||
|
||||
Finish the proof that products are propositional:
|
||||
|
||||
* `isProp (Product ...)`
|
||||
* `isProp (HasProducts ...)`
|
||||
|
||||
Remove --allow-unsolved-metas pragma from various files
|
||||
|
||||
Also renamed a lot of different projections. E.g. arrow-composition, etc..
|
||||
|
||||
Version 1.4.1
|
||||
-------------
|
||||
Defines a module to work with equivalence providing a way to go between
|
||||
|
|
@ -29,12 +62,12 @@ Adds an "equality principle" for categories and monads.
|
|||
Prove that `IsMonad` is a mere proposition.
|
||||
|
||||
Provides the yoneda embedding without relying on the existence of a category of
|
||||
categories. This is acheived by providing some of the data needed to make a ccc
|
||||
categories. This is achieved by providing some of the data needed to make a ccc
|
||||
out of the category of categories without actually having such a category.
|
||||
|
||||
Renames functors object map and arrow map to `omap` and `fmap`.
|
||||
|
||||
Prove that kleisli- and monoidal- monads are equivalent!
|
||||
Prove that Kleisli- and monoidal- monads are equivalent!
|
||||
|
||||
[WIP] Started working on the proofs for univalence for the category of sets and
|
||||
the category of functors.
|
||||
|
|
@ -42,7 +75,7 @@ the category of functors.
|
|||
Version 1.3.0
|
||||
-------------
|
||||
Removed unused modules and streamlined things more: All specific categories are
|
||||
in the namespace `Cat.Categories`.
|
||||
in the name space `Cat.Categories`.
|
||||
|
||||
Lemmas about categories are now in the appropriate record e.g. `IsCategory`.
|
||||
Also changed how category reexports stuff.
|
||||
|
|
@ -53,7 +86,7 @@ Rename Opposite to opposite
|
|||
|
||||
Add documentation in Category-module
|
||||
|
||||
Formulation of monads in two ways; the "monoidal-" and "kleisli-" form.
|
||||
Formulation of monads in two ways; the "monoidal-" and "Kleisli-" form.
|
||||
|
||||
WIP: Equivalence of these two formulations
|
||||
|
||||
|
|
|
|||
10
Makefile
10
Makefile
|
|
@ -1,5 +1,13 @@
|
|||
build: src/**.agda
|
||||
agda src/Cat.agda
|
||||
agda --library-file ./libraries src/Cat.agda
|
||||
|
||||
clean:
|
||||
find src -name "*.agdai" -type f -delete
|
||||
|
||||
html: src/**.agda
|
||||
agda --html src/Cat.agda
|
||||
|
||||
upload: html
|
||||
scp -r html/ remote11.chalmers.se:www/cat/doc/
|
||||
|
||||
.PHONY: upload clean
|
||||
|
|
|
|||
56
README.md
56
README.md
|
|
@ -1,38 +1,52 @@
|
|||
Description
|
||||
===========
|
||||
This project aims to formalize some parts of category theory using cubical agda
|
||||
— an extension to agda permitting univalence. To learn more about this
|
||||
[readthedocs](https://agda.readthedocs.io/en/latest/language/cubical.html).
|
||||
— an extension to agda permitting univalence. To learn more about this
|
||||
[read the docs](https://agda.readthedocs.io/en/latest/language/cubical.html).
|
||||
|
||||
This project draws a lot of inspiration from [the
|
||||
HoTT-book](https://homotopytypetheory.org/book/).
|
||||
|
||||
Installation
|
||||
============
|
||||
If you want more information about this project, then you're in luck.
|
||||
This is my masters thesis. Go ahead and read it
|
||||
[here](http://web.student.chalmers.se/~hanghj/papers/univalent-categories.pdf)
|
||||
or alternative like so:
|
||||
|
||||
cd doc/
|
||||
make
|
||||
|
||||
Dependencies
|
||||
------------
|
||||
To succesfully compile the following is needed:
|
||||
============
|
||||
To successfully compile the following is needed:
|
||||
|
||||
* The Agda release candidate 2.5.4[^1]
|
||||
* The experimental branch of [Agda Standard Library](https://github.com/agda/agda-stdlib)
|
||||
* The master branch of Agda.
|
||||
* [Agda Standard Library](https://github.com/agda/agda-stdlib)
|
||||
* [Cubical](https://github.com/Saizan/cubical-demo/)
|
||||
|
||||
[^1]: At least version >= [`707ce6042b6a3bdb26521f3fe8dfe5d8a8470a43`](https://github.com/agda/agda/commit/707ce6042b6a3bdb26521f3fe8dfe5d8a8470a43)
|
||||
Has been tested with:
|
||||
|
||||
It's important to have the right version of these - but which one is the right
|
||||
is in constant flux. It's most likely the newest one.
|
||||
* Agda version 2.6.0-d3efe64
|
||||
|
||||
I've used git submodules to manage dependencies. Unfortunately Agda does not
|
||||
allow specifying libraries to be used only as local dependencies. So the
|
||||
submodules are mostly used for documentation.
|
||||
Building
|
||||
========
|
||||
You can build the library with
|
||||
|
||||
You can let Agda know about these libraries by appending them to your global
|
||||
libraries file like so: (NB!: There is a good reason this is not in a
|
||||
makefile. So please verify that you know what you are doing, you probably
|
||||
already have standard-library in you libraries)
|
||||
git submodule update --init
|
||||
make
|
||||
|
||||
AGDA_LIB=~/.agda
|
||||
readlink -f libs/*/*.agda-lib | tee -a $AGDA_LIB/libraries
|
||||
The Makefile takes care of using the right dependencies.
|
||||
Unfortunately I have not found a way to automatically inform
|
||||
`agda-mode` that it should use these dependencies. So what you can do
|
||||
in stead is to copy these libraries to a global location and then add
|
||||
them system wide:
|
||||
|
||||
Anyways, assuming you have this set up you should be good to go.
|
||||
mkdir -p ~/.agda/libs
|
||||
cd ~/.agda/libs
|
||||
git clone $CAT/libs/std-lib
|
||||
git clone $CAT/libs/cubical
|
||||
echo << EOF | tee -a ~/.agda/libraries
|
||||
$HOME/.agda/libs/agda-stdlib/standard-library.agda-lib
|
||||
$HOME/.agda/libs/cubical/cubical.agda-lib
|
||||
EOF
|
||||
|
||||
Or you could symlink them as well if you want.
|
||||
|
|
|
|||
|
|
@ -4,5 +4,12 @@
|
|||
*.log
|
||||
*.out
|
||||
*.pdf
|
||||
!assets/**
|
||||
*.bbl
|
||||
*.blg
|
||||
*.toc
|
||||
*.idx
|
||||
*.ilg
|
||||
*.ind
|
||||
*.nav
|
||||
*.snm
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
Presentation
|
||||
====
|
||||
Find one clear goal.
|
||||
|
||||
Remember crowd-control.
|
||||
|
||||
Leave out:
|
||||
lemPropF
|
||||
|
||||
Outline
|
||||
-------
|
||||
|
||||
Introduction
|
||||
|
||||
A formalization of Category Theory in cubical Agda.
|
||||
|
||||
Cubical Agda: A constructive interpretation of functional
|
||||
extensionality and univalence
|
||||
|
||||
Talk about structure of library:
|
||||
===
|
||||
|
||||
What can I say about reusability?
|
||||
|
||||
Meeting with Andrea May 18th
|
||||
============================
|
||||
|
||||
App. 2 in HoTT gives typing rule for pathJ including a computational
|
||||
rule for it.
|
||||
|
||||
If you have this computational rule definitionally, then you wouldn't
|
||||
need to use `pathJprop`.
|
||||
|
||||
In discussion-section I mention HITs. I should remove this or come up
|
||||
with a more elaborate example of something you could do, e.g.
|
||||
something with pushouts in the category of sets.
|
||||
|
||||
The type Prop is a type where terms are *judgmentally* equal not just
|
||||
propositionally so.
|
||||
|
||||
Maybe mention that Andreas Källberg is working on proving the
|
||||
initiality conjecture.
|
||||
|
||||
Intensional Type Theory (ITT): Judgmental equality is decidable
|
||||
|
||||
Extensional Type Theory (ETT): Reflection is enough to make judgmental
|
||||
equality undecidable.
|
||||
|
||||
Reflection : a ≡ b → a = b
|
||||
|
||||
ITT does not have reflections.
|
||||
|
||||
HTT ~ ITT + axiomatized univalence
|
||||
Agda ~ ITT + K-rule
|
||||
Coq ~ ITT (no K-rule)
|
||||
Cubical Agda ~ ITT + Path + Glue
|
||||
|
||||
Prop is impredicative in Coq (whatever that means)
|
||||
|
||||
Prop ≠ hProp
|
||||
|
||||
Comments about abstract
|
||||
-----
|
||||
|
||||
Pattern matching for paths (?)
|
||||
|
||||
Intro
|
||||
-----
|
||||
Main feature of judgmental equality is the conversion rule.
|
||||
|
||||
Conor explained: K + eliminators ≡ pat. matching
|
||||
|
||||
Explain jugmental equality independently of type-checking
|
||||
|
||||
Soundness for equality means that if `x = y` then `x` and `y` must be
|
||||
equal according to the theory/model.
|
||||
|
||||
Decidability of `=` is a necessary condition for typechecking to be
|
||||
decidable.
|
||||
|
||||
Canonicity is a nice-to-have though without canonicity terms can get
|
||||
stuck. If we postulate results about judgmental equality. E.g. funext,
|
||||
then we can construct a term of type natural number that is not a
|
||||
numeral. Therefore stating canonicity with natural numbers:
|
||||
|
||||
∀ t . ⊢ t : N , ∃ n : N . ⊢ t = sⁿ 0 : N
|
||||
|
||||
is a sufficient condition to get a well-behaved equality.
|
||||
|
||||
Eta-equality for RawFunctor means that the associative law for
|
||||
functors hold definitionally.
|
||||
|
||||
Computational property for funExt is only relevant in two places in my
|
||||
whole formulation. Univalence and gradLemma does not influence any
|
||||
proofs.
|
||||
|
|
@ -3,17 +3,21 @@
|
|||
# Originally from : http://tex.stackexchange.com/a/40759
|
||||
#
|
||||
# Change only the variable below to the name of the main tex file.
|
||||
PROJNAME=proposal
|
||||
PROJNAME=univalent-categories
|
||||
MAIN=main.tex
|
||||
|
||||
# You want latexmk to *always* run, because make does not have all the info.
|
||||
# Also, include non-file targets in .PHONY so they are run regardless of any
|
||||
# file of the given name existing.
|
||||
.PHONY: $(PROJNAME).pdf all clean
|
||||
.PHONY: $(PROJNAME).pdf all clean preview
|
||||
|
||||
# The first rule in a Makefile is the one executed by default ("make"). It
|
||||
# should always be the "all" rule, so that "make" and "make all" are identical.
|
||||
all: $(PROJNAME).pdf
|
||||
|
||||
preview: $(MAIN)
|
||||
latexmk -pvc -jobname=$(PROJNAME) -pdf -xelatex $<
|
||||
|
||||
# CUSTOM BUILD RULES
|
||||
|
||||
# In case you didn't know, '$@' is a variable holding the name of the target,
|
||||
|
|
@ -36,11 +40,14 @@ all: $(PROJNAME).pdf
|
|||
# -interactive=nonstopmode keeps the pdflatex backend from stopping at a
|
||||
# missing file reference and interactively asking you for an alternative.
|
||||
|
||||
$(PROJNAME).pdf: $(PROJNAME).tex
|
||||
latexmk -pdf -pdflatex="pdflatex -interactive=nonstopmode" -use-make $<
|
||||
$(PROJNAME).pdf: $(MAIN)
|
||||
latexmk -jobname=$(PROJNAME) -pdf -xelatex -use-make $<
|
||||
|
||||
cleanall:
|
||||
latexmk -C
|
||||
|
||||
clean:
|
||||
latexmk -c
|
||||
|
||||
read: all
|
||||
xdg-open $(PROJNAME).pdf
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
\chapter*{Abstract}
|
||||
The usual notion of propositional equality in intensional type-theory
|
||||
is restrictive. For instance it does not admit functional
|
||||
extensionality nor univalence. This poses a severe limitation on both
|
||||
what is \emph{provable} and the \emph{re-usability} of proofs. Recent
|
||||
developments have, however, resulted in cubical type theory, which
|
||||
permits a constructive proof of univalence. The programming language
|
||||
Agda has been extended with capabilities for working in such a cubical
|
||||
setting. This thesis will explore the usefulness of this extension in
|
||||
the context of category theory.
|
||||
|
||||
The thesis will motivate the need for univalence and explain why
|
||||
propositional equality in cubical Agda is more expressive than in
|
||||
standard Agda. Alternative approaches to Cubical Agda will be
|
||||
presented and their pros and cons will be explained. As an example of
|
||||
the application of univalence, two formulations of monads will be
|
||||
presented: Namely monads in the monoidal form and monads in the
|
||||
Kleisli form. Using univalence, it will be shown how these are equal.
|
||||
|
||||
Finally the thesis will explain the challenges that a developer will
|
||||
face when working with cubical Agda and give some techniques to
|
||||
overcome these difficulties. It will suggest how further work can
|
||||
help alleviate some of these challenges.
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
\chapter*{Acknowledgements}
|
||||
I would like to thank my supervisor Thierry Coquand for giving me a
|
||||
chance to work on this interesting topic. I would also like to thank
|
||||
Andrea Vezzosi for some very long and very insightful meetings during
|
||||
the project. It is fascinating and almost uncanny how quickly Andrea
|
||||
can conjure up various proofs. I also want to recognize the support
|
||||
of Knud Højgaards Fond who graciously sponsored me with a 20.000 DKK
|
||||
scholarship which helped toward sponsoring the two years I have spent
|
||||
studying abroad. I would also like to give a warm thanks to my fellow
|
||||
students Pierre~Kraft and Nachiappan~Valliappan who have made the time
|
||||
spent working on the thesis way more enjoyable. Lastly I would like to
|
||||
give a special thanks to Valentina~Méndez who have been a great moral
|
||||
support throughout the whole process.
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
\lstset{basicstyle=\footnotesize\ttfamily,breaklines=true,breakpages=true}
|
||||
\def\fileps
|
||||
{ ../src/Cat.agda
|
||||
, ../src/Cat/Categories/Cat.agda
|
||||
, ../src/Cat/Categories/Cube.agda
|
||||
, ../src/Cat/Categories/CwF.agda
|
||||
, ../src/Cat/Categories/Fam.agda
|
||||
, ../src/Cat/Categories/Free.agda
|
||||
, ../src/Cat/Categories/Fun.agda
|
||||
, ../src/Cat/Categories/Rel.agda
|
||||
, ../src/Cat/Categories/Sets.agda
|
||||
, ../src/Cat/Category.agda
|
||||
, ../src/Cat/Category/CartesianClosed.agda
|
||||
, ../src/Cat/Category/Exponential.agda
|
||||
, ../src/Cat/Category/Functor.agda
|
||||
, ../src/Cat/Category/Monad.agda
|
||||
, ../src/Cat/Category/Monad/Kleisli.agda
|
||||
, ../src/Cat/Category/Monad/Monoidal.agda
|
||||
, ../src/Cat/Category/Monad/Voevodsky.agda
|
||||
, ../src/Cat/Category/Monoid.agda
|
||||
, ../src/Cat/Category/NaturalTransformation.agda
|
||||
, ../src/Cat/Category/Product.agda
|
||||
, ../src/Cat/Category/Yoneda.agda
|
||||
, ../src/Cat/Equivalence.agda
|
||||
, ../src/Cat/Prelude.agda
|
||||
}
|
||||
|
||||
\foreach \filep in \fileps {
|
||||
\chapter{\filep}
|
||||
%% \begin{figure}[htpb]
|
||||
\lstinputlisting{\filep}
|
||||
%% \caption{Source code for \texttt{\filep}}
|
||||
%% \label{fig:\filep}
|
||||
%% \end{figure}
|
||||
}
|
||||
%% \lstset{framextopmargin=50pt}
|
||||
%% \lstinputlisting{../../src/Cat.agda}
|
||||
|
|
@ -0,0 +1,74 @@
|
|||
\chapter{Non-reducing functional extensionality}
|
||||
\label{app:abstract-funext}
|
||||
In two places in my formalization was the computational behaviours of
|
||||
functional extensionality used. The reduction behaviour can be
|
||||
disabled by marking functional extensionality as abstract. Below the
|
||||
fully normalized goal and context with functional extensionality
|
||||
marked abstract has been shown. The excerpts are from the module
|
||||
%
|
||||
\begin{center}
|
||||
\sourcelink{Cat.Category.Monad.Voevodsky}
|
||||
\end{center}
|
||||
%
|
||||
where this is also written as a comment next to the proofs. When
|
||||
functional extensionality is not abstract the goal and current value
|
||||
are the same. It is of course necessary to show the fully normalized
|
||||
goal and context otherwise the reduction behaviours is not forced.
|
||||
|
||||
\subsubsection*{First goal}
|
||||
Goal:
|
||||
\begin{verbatim}
|
||||
PathP (λ _ → §2-3.§2 omap (λ {z} → pure))
|
||||
(§2-fromMonad
|
||||
(.Cat.Category.Monad.toKleisli ℂ
|
||||
(.Cat.Category.Monad.toMonoidal ℂ (§2-3.§2.toMonad m))))
|
||||
(§2-fromMonad (§2-3.§2.toMonad m))
|
||||
\end{verbatim}
|
||||
Have:
|
||||
\begin{verbatim}
|
||||
PathP
|
||||
(λ i →
|
||||
§2-3.§2 K.IsMonad.omap
|
||||
(K.RawMonad.pure
|
||||
(K.Monad.raw
|
||||
(funExt (λ m₁ → K.Monad≡ (.Cat.Category.Monad.toKleisliRawEq ℂ m₁))
|
||||
i (§2-3.§2.toMonad m)))))
|
||||
(§2-fromMonad
|
||||
(.Cat.Category.Monad.toKleisli ℂ
|
||||
(.Cat.Category.Monad.toMonoidal ℂ (§2-3.§2.toMonad m))))
|
||||
(§2-fromMonad (§2-3.§2.toMonad m))
|
||||
\end{verbatim}
|
||||
\subsubsection*{Second goal}
|
||||
Goal:
|
||||
\begin{verbatim}
|
||||
PathP (λ _ → §2-3.§1 omap (λ {X} → pure))
|
||||
(§1-fromMonad
|
||||
(.Cat.Category.Monad.toMonoidal ℂ
|
||||
(.Cat.Category.Monad.toKleisli ℂ (§2-3.§1.toMonad m))))
|
||||
(§1-fromMonad (§2-3.§1.toMonad m))
|
||||
\end{verbatim}
|
||||
Have:
|
||||
\begin{verbatim}
|
||||
PathP
|
||||
(λ i →
|
||||
§2-3.§1
|
||||
(RawFunctor.omap
|
||||
(Functor.raw
|
||||
(M.RawMonad.R
|
||||
(M.Monad.raw
|
||||
(funExt
|
||||
(λ m₁ → M.Monad≡ (.Cat.Category.Monad.toMonoidalRawEq ℂ m₁)) i
|
||||
(§2-3.§1.toMonad m))))))
|
||||
(λ {X} →
|
||||
fst
|
||||
(M.RawMonad.pureNT
|
||||
(M.Monad.raw
|
||||
(funExt
|
||||
(λ m₁ → M.Monad≡ (.Cat.Category.Monad.toMonoidalRawEq ℂ m₁)) i
|
||||
(§2-3.§1.toMonad m))))
|
||||
X))
|
||||
(§1-fromMonad
|
||||
(.Cat.Category.Monad.toMonoidal ℂ
|
||||
(.Cat.Category.Monad.toKleisli ℂ (§2-3.§1.toMonad m))))
|
||||
(§1-fromMonad (§2-3.§1.toMonad m))
|
||||
\end{verbatim}
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
After Width: | Height: | Size: 266 KiB |
Binary file not shown.
Binary file not shown.
Binary file not shown.
|
|
@ -0,0 +1,140 @@
|
|||
% Requires: hypperref
|
||||
\ProvidesPackage{chalmerstitle}
|
||||
|
||||
%% \RequirePackage{kvoptions}
|
||||
|
||||
%% \SetupKeyvalOptions{
|
||||
%% family=ct,
|
||||
%% prefix=ct@
|
||||
%% }
|
||||
|
||||
%% \DeclareStringOption{authoremail}
|
||||
%% \DeclareStringOption{supervisor}
|
||||
%% \DeclareStringOption{supervisoremail}
|
||||
%% \DeclareStringOption{supervisordepartment}
|
||||
%% \DeclareStringOption{cosupervisor}
|
||||
%% \DeclareStringOption{cosupervisoremail}
|
||||
%% \DeclareStringOption{cosupervisordepartment}
|
||||
%% \DeclareStringOption{examiner}
|
||||
%% \DeclareStringOption{examineremail}
|
||||
%% \DeclareStringOption{examinerdepartment}
|
||||
%% \DeclareStringOption{institution}
|
||||
%% \DeclareStringOption{department}
|
||||
%% \DeclareStringOption{researchgroup}
|
||||
%% \DeclareStringOption{subtitle}
|
||||
%% \ProcessKeyvalOptions*
|
||||
|
||||
\newcommand*{\authoremail}[1]{\gdef\@authoremail{#1}}
|
||||
\newcommand*{\supervisor}[1]{\gdef\@supervisor{#1}}
|
||||
\newcommand*{\supervisoremail}[1]{\gdef\@supervisoremail{#1}}
|
||||
\newcommand*{\supervisordepartment}[1]{\gdef\@supervisordepartment{#1}}
|
||||
\newcommand*{\cosupervisor}[1]{\gdef\@cosupervisor{#1}}
|
||||
\newcommand*{\cosupervisoremail}[1]{\gdef\@cosupervisoremail{#1}}
|
||||
\newcommand*{\cosupervisordepartment}[1]{\gdef\@cosupervisordepartment{#1}}
|
||||
\newcommand*{\examiner}[1]{\gdef\@examiner{#1}}
|
||||
\newcommand*{\examineremail}[1]{\gdef\@examineremail{#1}}
|
||||
\newcommand*{\examinerdepartment}[1]{\gdef\@examinerdepartment{#1}}
|
||||
\newcommand*{\institution}[1]{\gdef\@institution{#1}}
|
||||
\newcommand*{\department}[1]{\gdef\@department{#1}}
|
||||
\newcommand*{\researchgroup}[1]{\gdef\@researchgroup{#1}}
|
||||
\newcommand*{\subtitle}[1]{\gdef\@subtitle{#1}}
|
||||
%% FRONTMATTER
|
||||
\newcommand*{\myfrontmatter}{%
|
||||
%% \newgeometry{top=3cm, bottom=3cm,left=2.25 cm, right=2.25cm}
|
||||
\AddToShipoutPicture*{\backgroundpic{-4}{56.7}{assets/frontpage_gu_eng.pdf}}
|
||||
\ClearShipoutPicture
|
||||
\addtolength{\voffset}{2cm}
|
||||
\begingroup
|
||||
\thispagestyle{empty}
|
||||
{\Huge\@title}\\[.5cm]
|
||||
{\Large A formalization of category theory in Cubical Agda}\\[6cm]
|
||||
\begin{center}
|
||||
\includegraphics[width=\linewidth,keepaspectratio]{assets/isomorphism.pdf}
|
||||
%% \includepdf{isomorphism.pdf}
|
||||
\end{center}
|
||||
% Cover text
|
||||
\vfill
|
||||
%% \renewcommand{\familydefault}{\sfdefault} \normalfont % Set cover page font
|
||||
{\Large\@author}\\[.5cm]
|
||||
Master's thesis in Computer Science
|
||||
\endgroup
|
||||
%% \end{titlepage}
|
||||
|
||||
|
||||
% BACK OF COVER PAGE (BLANK PAGE)
|
||||
\newpage
|
||||
%% \newgeometry{a4paper} % Temporarily change margins
|
||||
\restoregeometry
|
||||
\thispagestyle{empty}
|
||||
\null
|
||||
}
|
||||
|
||||
\renewcommand*{\maketitle}{%
|
||||
%% \begin{titlepage}
|
||||
|
||||
% TITLE PAGE
|
||||
\newpage
|
||||
\thispagestyle{empty}
|
||||
\begin{center}
|
||||
\textsc{\LARGE Master's thesis \the\year}\\[4cm] % Report number is currently not in use
|
||||
\textbf{\LARGE \@title} \\[1cm]
|
||||
{\large \@subtitle}\\[1cm]
|
||||
{\large \@author}
|
||||
|
||||
\vfill
|
||||
\centering
|
||||
\includegraphics[width=0.2\pdfpagewidth]{assets/logo_eng.pdf}
|
||||
\vspace{5mm}
|
||||
|
||||
\textsc{Department of Computer Science and Engineering}\\
|
||||
\textsc{{\@researchgroup}}\\
|
||||
%Name of research group (if applicable)\\
|
||||
\textsc{\@institution} \\
|
||||
\textsc{Gothenburg, Sweden \the\year}\\
|
||||
\end{center}
|
||||
|
||||
|
||||
% IMPRINT PAGE (BACK OF TITLE PAGE)
|
||||
\newpage
|
||||
\thispagestyle{plain}
|
||||
\textit{\@title}\\
|
||||
\@subtitle\\
|
||||
\copyright\ \the\year ~ \textsc{\@author}
|
||||
\vspace{4.5cm}
|
||||
|
||||
\setlength{\parskip}{0.5cm}
|
||||
\textbf{Author:}\\
|
||||
\@author\\
|
||||
\href{mailto:\@authoremail>}{\texttt{<\@authoremail>}}
|
||||
|
||||
\textbf{Supervisor:}\\
|
||||
\@supervisor\\
|
||||
\href{mailto:\@supervisoremail>}{\texttt{<\@supervisoremail>}}\\
|
||||
\@supervisordepartment
|
||||
|
||||
\textbf{Co-supervisor:}\\
|
||||
\@cosupervisor\\
|
||||
\href{mailto:\@cosupervisoremail>}{\texttt{<\@cosupervisoremail>}}\\
|
||||
\@cosupervisordepartment
|
||||
|
||||
\textbf{Examiner:}\\
|
||||
\@examiner\\
|
||||
\href{mailto:\@examineremail>}{\texttt{<\@examineremail>}}\\
|
||||
\@examinerdepartment
|
||||
|
||||
\vfill
|
||||
Master's Thesis \the\year\\ % Report number currently not in use
|
||||
\@department\\
|
||||
%Division of Division name\\
|
||||
%Name of research group (if applicable)\\
|
||||
\@institution\\
|
||||
SE-412 96 Gothenburg\\
|
||||
Telephone +46 31 772 1000 \setlength{\parskip}{0.5cm}\\
|
||||
% Caption for cover page figure if used, possibly with reference to further information in the report
|
||||
%% Cover: Wind visualization constructed in Matlab showing a surface of constant wind speed along with streamlines of the flow. \setlength{\parskip}{0.5cm}
|
||||
%Printed by [Name of printing company]\\
|
||||
Gothenburg, Sweden \the\year
|
||||
|
||||
%% \restoregeometry
|
||||
%% \end{titlepage}
|
||||
}
|
||||
|
|
@ -0,0 +1,63 @@
|
|||
\chapter{Conclusion}
|
||||
This thesis highlighted some issues with the standard inductive
|
||||
definition of propositional equality used in Agda. Functional
|
||||
extensionality and univalence are examples of two propositions not
|
||||
admissible in Intensional Type Theory (ITT). This has a big impact on
|
||||
what is provable and the reusability of proofs. This issue is
|
||||
overcome with an extension to Agda's type system called Cubical Agda.
|
||||
With Cubical Agda both functional extensionality and univalence are
|
||||
admissible. Cubical Agda is more expressive, but there are certain
|
||||
issues that arise that are not present in standard Agda. For one
|
||||
thing Agda enjoys Uniqueness of Identity Proofs (UIP) though a flag
|
||||
exists to turn this off. This feature is not present in Cubical Agda.
|
||||
Rather than having unique identity proofs cubical Agda gives rise to a
|
||||
hierarchy of types with increasing \nomen{homotopical
|
||||
structure}{homotopy levels}. It turns out to be useful to build the
|
||||
formalization with this hierarchy in mind as it can simplify proofs
|
||||
considerably. Another issue one must overcome in Cubical Agda is when
|
||||
a type has a field whose type depends on a previous field. In this
|
||||
case paths between such types will be heterogeneous paths. In
|
||||
practice it turns out to be considerably more difficult to work with
|
||||
heterogeneous paths than with homogeneous paths. This thesis
|
||||
demonstrated the application of some techniques to overcome these
|
||||
difficulties, such as based path induction.
|
||||
|
||||
This thesis formalizes some of the core concepts from category theory
|
||||
including: categories, functors, products, exponentials, Cartesian
|
||||
closed categories, natural transformations, the yoneda embedding,
|
||||
monads and more. Category theory is an interesting case study for the
|
||||
application of cubical Agda for two reasons in particular. One reason
|
||||
is because category theory is the study of abstract algebra of
|
||||
functions, meaning that functional extensionality is particularly
|
||||
relevant. Another reason is that in category theory it is commonplace
|
||||
to identify isomorphic structures. Univalence allows for making this
|
||||
notion precise. This thesis also demonstrated another technique that
|
||||
is common in category theory; namely to define categories to prove
|
||||
properties of other structures. Specifically a category was defined
|
||||
to demonstrate that any two product objects in a category are
|
||||
isomorphic. Furthermore the thesis showed two formulations of monads
|
||||
and proved that they indeed are equivalent: Namely monads in the
|
||||
monoidal- and Kleisli- form. The monoidal formulation is more typical
|
||||
to category theoretic formulations and the Kleisli formulation will be
|
||||
more familiar to functional programmers. It would have been very
|
||||
difficult to make a similar proof with setoids and the proof would be
|
||||
very difficult to read. In the formulation we also saw how paths can
|
||||
be used to extract functions. A path between two types induce an
|
||||
isomorphism between the two types. This e.g.\ permits developers to
|
||||
write a monad instance for a given type using the Kleisli formulation.
|
||||
By transporting along the path between the monoidal- and Kleisli-
|
||||
formulation one can reuse all the operations and results shown for
|
||||
monoidal- monads in the context of kleisli monads.
|
||||
%%
|
||||
%% problem with inductive type
|
||||
%% overcome with cubical
|
||||
%% the path type
|
||||
%% homotopy levels
|
||||
%% depdendent paths
|
||||
%%
|
||||
%% category theory
|
||||
%% algebra of functions ~ funExt
|
||||
%% identify isomorphic types ~ univalence
|
||||
%% using categories to prove properties
|
||||
%% computational properties
|
||||
%% reusability, compositional
|
||||
|
|
@ -0,0 +1,428 @@
|
|||
\chapter{Cubical Agda}
|
||||
\section{Propositional equality}
|
||||
Judgmental equality in Agda is a feature of the type system. It is
|
||||
something that can be checked automatically by the type checker: In
|
||||
the example from the introduction $n + 0$ can be judged to be equal to
|
||||
$n$ simply by expanding the definition of $+$.
|
||||
|
||||
On the other hand, propositional equality is something defined within
|
||||
the language itself. Propositional equality cannot be derived
|
||||
automatically. The normal definition of propositional equality is an
|
||||
inductive data type. Cubical Agda discards this type in favor of some
|
||||
new primitives.
|
||||
|
||||
Most of the source code related with this section is implemented in
|
||||
\cite{cubical-demo} it can be browsed in hyperlinked and syntax
|
||||
highlighted HTML online. The links can be found in the beginning of
|
||||
section \S\ref{ch:implementation}.
|
||||
|
||||
\subsection{The equality type}
|
||||
The usual notion of judgmental equality says that given a type $A \tp
|
||||
\MCU$ and two points hereof $a_0, a_1 \tp A$ we can form the type:
|
||||
%
|
||||
\begin{align}
|
||||
a_0 \equiv a_1 \tp \MCU
|
||||
\end{align}
|
||||
%
|
||||
In Agda this is defined as an inductive data type with the single
|
||||
constructor $\refl$ that for any $a \tp A$ gives:
|
||||
%
|
||||
\begin{align}
|
||||
\refl \tp a \equiv a
|
||||
\end{align}
|
||||
%
|
||||
There also exist a related notion of \emph{heterogeneous} equality which allows
|
||||
for equating points of different types. In this case given two types $A, B \tp
|
||||
\MCU$ and two points $a \tp A$, $b \tp B$ we can construct the type:
|
||||
%
|
||||
\begin{align}
|
||||
a \cong b \tp \MCU
|
||||
\end{align}
|
||||
%
|
||||
This likewise has the single constructor $\refl$ that for any $a \tp
|
||||
A$ gives:
|
||||
%
|
||||
\begin{align}
|
||||
\refl \tp a \cong a
|
||||
\end{align}
|
||||
%
|
||||
In Cubical Agda these two notions are paralleled with homogeneous- and
|
||||
heterogeneous paths respectively.
|
||||
%
|
||||
\subsection{The path type}
|
||||
Judgmental equality in Cubical Agda is encapsulated with the type:
|
||||
%
|
||||
\begin{equation}
|
||||
\Path \tp (P \tp \I → \MCU) → P\ 0 → P\ 1 → \MCU
|
||||
\end{equation}
|
||||
%
|
||||
The special type $\I$ is called the index set. The index set can be
|
||||
thought of simply as the interval on the real numbers from $0$ to $1$
|
||||
(both inclusive). The family $P$ over $\I$ will be referred to as the
|
||||
\nomenindex{path space} given some path $p \tp \Path\ P\ a\ b$. By
|
||||
that token $P\ 0$ corresponds to the type at the left endpoint of $p$.
|
||||
Likewise $P\ 1$ is the type at the right endpoint. The type is called
|
||||
$\Path$ because the idea has roots in homotopy theory. The intuition
|
||||
is that $\Path$ describes\linebreak[1] paths in $\MCU$. I.e.\ paths
|
||||
between types. For a path $p$ the expression $p\ i$ can be thought of
|
||||
as a \emph{point} on this path. The index $i$ describes how far along
|
||||
the path one has moved. An inhabitant of $\Path\ P\ a_0\ a_1$ is a
|
||||
(dependent) function from the index set to the path space:
|
||||
%
|
||||
$$
|
||||
p \tp \prod_{i \tp \I} P\ i
|
||||
$$
|
||||
%
|
||||
This function must satisfy being judgmentally equal to $a_0$ at the
|
||||
left endpoint and equal to $a_1$ at the other end. I.e.:
|
||||
%
|
||||
\begin{align*}
|
||||
p\ 0 & = a_0 \\
|
||||
p\ 1 & = a_1
|
||||
\end{align*}
|
||||
%
|
||||
The notion of \nomenindex{homogeneous equalities} is recovered when $P$ does not
|
||||
depend on its argument. That is for $A \tp \MCU$ and $a_0, a_1 \tp A$ the
|
||||
homogenous equality between $a_0$ and $a_1$ is the type:
|
||||
%
|
||||
$$
|
||||
a_0 \equiv a_1 \defeq \Path\ (\lambda\;i \to A)\ a_0\ a_1
|
||||
$$
|
||||
%
|
||||
I will generally prefer to use the notation $a \equiv b$ when talking
|
||||
about non-dependent paths and use the notation $\Path\ (\lambda\; i
|
||||
\to P\ i)\ a\ b$ when the path space is of particular interest.
|
||||
|
||||
With this definition we can recover reflexivity. That is, for any $A
|
||||
\tp \MCU$ and $a \tp A$:
|
||||
%
|
||||
\begin{equation}
|
||||
\begin{aligned}
|
||||
\refl & \tp a \equiv a \\
|
||||
\refl & \defeq \lambda\; i \to a
|
||||
\end{aligned}
|
||||
\end{equation}
|
||||
%
|
||||
Here the path space is $P \defeq \lambda\; i \to A$ and it satsifies
|
||||
$P\ i = A$ definitionally. So to inhabit it, is to give a path $\I \to
|
||||
A$ that is judgmentally $a$ at either endpoint. This is satisfied by
|
||||
the constant path; i.e.\ the path that is constantly $a$ at any index
|
||||
$i \tp \I$.
|
||||
|
||||
It is also surprisingly easy to show functional extensionality.
|
||||
Functional extensionality is the proposition that given a type $A \tp
|
||||
\MCU$, a family of types $B \tp A \to \MCU$ and functions $f, g \tp
|
||||
\prod_{a \tp A} B\ a$ gives:
|
||||
%
|
||||
\begin{equation}
|
||||
\label{eq:funExt}
|
||||
\funExt \tp \left(\prod_{a \tp A} f\ a \equiv g\ a \right) \to f \equiv g
|
||||
\end{equation}
|
||||
%
|
||||
%% p = λ\; i a → p a i
|
||||
So given $η \tp \prod_{a \tp A} f\ a \equiv g\ a$ we must give a path
|
||||
$f \equiv g$. That is a function $\I \to \prod_{a \tp A} B\ a$. So let
|
||||
$i \tp \I$ be given. We must now give an expression $\phi \tp
|
||||
\prod_{a \tp A} B\ a$ satisfying $\phi\ 0 \equiv f\ a$ and $\phi\ 1
|
||||
\equiv g\ a$. This neccesitates that the expression must be a lambda
|
||||
abstraction, so let $a \tp A$ be given. We can now apply $a$ to $η$
|
||||
and get the path $η\ a \tp f\ a \equiv g\ a$. This exactly
|
||||
satisfies the conditions for $\phi$. In conclusion \ref{eq:funExt} is
|
||||
inhabited by the term:
|
||||
%
|
||||
\begin{equation*}
|
||||
\funExt\ η \defeq λ\; i\ a → η\ a\ i
|
||||
\end{equation*}
|
||||
%
|
||||
With $\funExt$ in place we can now construct a path between
|
||||
$\var{zeroLeft}$ and $\var{zeroRight}$ -- the functions defined in the
|
||||
introduction \S\ref{sec:functional-extensionality}:
|
||||
%
|
||||
\begin{align*}
|
||||
p & \tp \var{zeroLeft} \equiv \var{zeroRight} \\
|
||||
p & \defeq \funExt\ \var{zrn}
|
||||
\end{align*}
|
||||
%
|
||||
Here $\var{zrn}$ is the proof from \ref{eq:zrn}.
|
||||
%
|
||||
\section{Homotopy levels}
|
||||
In ITT all equality proofs are identical (in a closed context). This
|
||||
means that, in some sense, any two inhabitants of $a \equiv b$ are
|
||||
``equally good''. They do not have any interesting structure. This is
|
||||
referred to as Uniqueness of Identity Proofs (UIP). Unfortunately it
|
||||
is not possible to have a type theory with both univalence and UIP.
|
||||
Instead in cubical Agda we have a hierarchy of types with an
|
||||
increasing amount of homotopic structure. At the bottom of this
|
||||
hierarchy is the set of contractible types:
|
||||
%
|
||||
\begin{equation}
|
||||
\begin{aligned}
|
||||
%% \begin{split}
|
||||
& \isContr && \tp \MCU \to \MCU \\
|
||||
& \isContr\ A && \defeq \sum_{c \tp A} \prod_{a \tp A} a \equiv c
|
||||
%% \end{split}
|
||||
\end{aligned}
|
||||
\end{equation}
|
||||
%
|
||||
The first component of $\isContr\ A$ is called ``the center of contraction''.
|
||||
Under the propositions-as-types interpretation of type theory $\isContr\ A$ can
|
||||
be thought of as ``the true proposition $A$''. And indeed $\top$ is
|
||||
contractible:
|
||||
%
|
||||
\begin{equation*}
|
||||
(\var{tt} , \lambda\; x \to \refl) \tp \isContr\ \top
|
||||
\end{equation*}
|
||||
%
|
||||
It is a theorem that if a type is contractible, then it is isomorphic to the
|
||||
unit-type.
|
||||
|
||||
The next step in the hierarchy is the set of mere propositions:
|
||||
%
|
||||
\begin{equation}
|
||||
\begin{aligned}
|
||||
& \isProp && \tp \MCU \to \MCU \\
|
||||
& \isProp\ A && \defeq \prod_{a_0, a_1 \tp A} a_0 \equiv a_1
|
||||
\end{aligned}
|
||||
\end{equation}
|
||||
%
|
||||
One can think of $\isProp\ A$ as the set of true and false propositions. And
|
||||
indeed both $\top$ and $\bot$ are propositions:
|
||||
%
|
||||
\begin{align*}
|
||||
(λ\; \var{tt}, \var{tt} → refl) & \tp \isProp\ ⊤ \\
|
||||
λ\;\varnothing\ \varnothing & \tp \isProp\ ⊥
|
||||
\end{align*}
|
||||
%
|
||||
The term $\varnothing$ is used here to denote an impossible pattern. It is a
|
||||
theorem that if a mere proposition $A$ is inhabited, then so is it contractible.
|
||||
If it is not inhabited it is equivalent to the empty-type (or false
|
||||
proposition).
|
||||
|
||||
I will refer to a type $A \tp \MCU$ as a \emph{mere proposition} if I want to
|
||||
stress that we have $\isProp\ A$.
|
||||
|
||||
The next step in the hierarchy is the set of homotopical sets:
|
||||
%
|
||||
\begin{equation}
|
||||
\begin{aligned}
|
||||
& \isSet && \tp \MCU \to \MCU \\
|
||||
& \isSet\ A && \defeq \prod_{a_0, a_1 \tp A} \isProp\ (a_0 \equiv a_1)
|
||||
\end{aligned}
|
||||
\end{equation}
|
||||
%
|
||||
I will not give an example of a set at this point. It turns out that
|
||||
proving e.g.\ $\isProp\ \bN$ directly is not so straightforward (see
|
||||
\cite[\S3.1.4]{hott-2013}). Hedberg's theorem states that any type
|
||||
with decidable equality is a set. There will be examples of sets later
|
||||
in this report. At this point it should be noted that the term ``set''
|
||||
is somewhat conflated; there is the notion of sets from set theory.
|
||||
In Agda types are denoted \texttt{Set}. I will use it consistently to
|
||||
refer to a type $A$ as a set exactly if $\isSet\ A$ is a proposition.
|
||||
|
||||
As the reader may have guessed the next step in the hierarchy is the type:
|
||||
%
|
||||
\begin{equation}
|
||||
\begin{aligned}
|
||||
& \isGroupoid && \tp \MCU \to \MCU \\
|
||||
& \isGroupoid\ A && \defeq \prod_{a_0, a_1 \tp A} \isSet\ (a_0 \equiv a_1)
|
||||
\end{aligned}
|
||||
\end{equation}
|
||||
%
|
||||
So it continues. In fact we can generalize this family of types by
|
||||
indexing them with a natural number. For historical reasons, though,
|
||||
the bottom of the hierarchy, the contractible types, is said to be a
|
||||
\nomen{-2-type}{homotopy levels}, propositions are
|
||||
\nomen{-1-types}{homotopy levels}, (homotopical) sets are
|
||||
\nomen{0-types}{homotopy levels} and so on\ldots
|
||||
|
||||
Just as with paths, homotopical sets are not at the center of focus for this
|
||||
thesis. But I mention here some properties that will be relevant for this
|
||||
exposition:
|
||||
|
||||
Proposition: Homotopy levels are cumulative. That is, if $A \tp \MCU$ has
|
||||
homotopy level $n$ then so does it have $n + 1$.
|
||||
|
||||
For any level $n$ it is the case that to be of level $n$ is a mere proposition.
|
||||
%
|
||||
\section{A few lemmas}
|
||||
Rather than getting into the nitty-gritty details of Agda I venture to
|
||||
take a more ``combinator-based'' approach. That is I will use
|
||||
theorems about paths that have already been formalized.
|
||||
Specifically the results come from the Agda library \texttt{cubical}
|
||||
(\cite{cubical-demo}). I have used a handful of results from this
|
||||
library as well as contributed a few lemmas myself%
|
||||
\footnote{The module \texttt{Cat.Prelude} lists the upstream
|
||||
dependencies. My contribution to \texttt{cubical} can as well be
|
||||
found in the git logs which are available at
|
||||
\hrefsymb{https://github.com/Saizan/cubical-demo}{\texttt{https://github.com/Saizan/cubical-demo}}.
|
||||
}.
|
||||
|
||||
These theorems are all purely related to homotopy type theory and as
|
||||
such not specific to the formalization of Category Theory. I will
|
||||
present a few of these theorems here as they will be used throughout
|
||||
chapter \ref{ch:implementation}. They should also give the reader some
|
||||
intuition about the path type.
|
||||
|
||||
\subsection{Path induction}
|
||||
\label{sec:pathJ}
|
||||
The induction principle for paths intuitively gives us a way to reason
|
||||
about a type family indexed by a path by only considering if said path
|
||||
is $\refl$ (the \nomen{base case}{path induction}). For \emph{based
|
||||
path induction}, that equality is \emph{based} at some element $a
|
||||
\tp A$.
|
||||
|
||||
\pagebreak[3]
|
||||
\begin{samepage}
|
||||
Let a type $A \tp \MCU$ and an element of the type $a \tp A$ be
|
||||
given. $a$ is said to be the base of the induction.\linebreak[3] Given
|
||||
a family of types:
|
||||
%
|
||||
$$
|
||||
D \tp \prod_{b \tp A} \prod_{p \tp a ≡ b} \MCU
|
||||
$$
|
||||
%
|
||||
and an inhabitant of $D$ at $\refl$:
|
||||
%
|
||||
$$
|
||||
d \tp D\ a\ \refl
|
||||
$$
|
||||
We have the function:
|
||||
%
|
||||
\begin{equation}
|
||||
\pathJ\ D\ d \tp \prod_{b \tp A} \prod_{p \tp a ≡ b} D\ b\ p
|
||||
\end{equation}
|
||||
\end{samepage}%
|
||||
|
||||
A simple application of $\pathJ$ is for proving that $\var{sym}$ is an
|
||||
involution. Namely for any set $A \tp \MCU$, points $a, b \tp A$ and a path
|
||||
between them $p \tp a \equiv b$:
|
||||
%
|
||||
\begin{equation}
|
||||
\label{eq:sym-invol}
|
||||
\var{sym}\ (\var{sym}\ p) ≡ p
|
||||
\end{equation}
|
||||
%
|
||||
The proof will be by induction on $p$ and will be based at $a$. That
|
||||
is $D$ will be the family:
|
||||
%
|
||||
\begin{align*}
|
||||
D & \tp \prod_{b' \tp A} \prod_{p \tp a ≡ b'} \MCU \\
|
||||
D\ b'\ p' & \defeq \var{sym}\ (\var{sym}\ p') ≡ p'
|
||||
\end{align*}
|
||||
%
|
||||
The base case will then be:
|
||||
%
|
||||
\begin{align*}
|
||||
d & \tp \var{sym}\ (\var{sym}\ \refl) ≡ \refl \\
|
||||
d & \defeq \refl
|
||||
\end{align*}
|
||||
%
|
||||
The reason $\refl$ proves this is that $\var{sym}\ \refl = \refl$ holds
|
||||
definitionally. In summary \ref{eq:sym-invol} is inhabited by the term:
|
||||
%
|
||||
\begin{align*}
|
||||
\pathJ\ D\ d\ b\ p
|
||||
\tp
|
||||
\var{sym}\ (\var{sym}\ p) ≡ p
|
||||
\end{align*}
|
||||
%
|
||||
Another application of $\pathJ$ is for proving associativity of $\trans$. That
|
||||
is, given a type $A \tp \MCU$, elements of $A$, $a, b, c, d \tp A$ and paths
|
||||
between them $p \tp a \equiv b$, $q \tp b \equiv c$ and $r \tp c \equiv d$ we
|
||||
have the following:
|
||||
%
|
||||
\begin{equation}
|
||||
\label{eq:cum-trans}
|
||||
\trans\ p\ (\trans\ q\ r) ≡ \trans\ (\trans\ p\ q)\ r
|
||||
\end{equation}
|
||||
%
|
||||
In this case the induction will be based at $c$ (the left-endpoint of $r$) and
|
||||
over the family:
|
||||
%
|
||||
\begin{align*}
|
||||
T & \tp \prod_{d' \tp A} \prod_{r' \tp c ≡ d'} \MCU \\
|
||||
T\ d'\ r' & \defeq \trans\ p\ (\trans\ q\ r') ≡ \trans\ (\trans\ p\ q)\ r'
|
||||
\end{align*}
|
||||
%
|
||||
The base case is proven with $t$ which is defined as:
|
||||
%
|
||||
\begin{align*}
|
||||
\trans\ p\ (\trans\ q\ \refl) & ≡
|
||||
\trans\ p\ q \\
|
||||
& ≡
|
||||
\trans\ (\trans\ p\ q)\ \refl
|
||||
\end{align*}
|
||||
%
|
||||
Here we have used the proposition $\trans\ p\ \refl \equiv p$ without proof. In
|
||||
conclusion \ref{eq:cum-trans} is inhabited by the term:
|
||||
%
|
||||
\begin{align*}
|
||||
\pathJ\ T\ t\ d\ r
|
||||
\end{align*}
|
||||
%
|
||||
We shall see another application of path induction in \ref{eq:pathJ-example}.
|
||||
|
||||
\subsection{Paths over propositions}
|
||||
\label{sec:lemPropF}
|
||||
Another very useful combinator is $\lemPropF$: Given a type $A \tp
|
||||
\MCU$ and a type family on $A$; $D \tp A \to \MCU$. Let $\var{propD}
|
||||
\tp \prod_{x \tp A} \isProp\ (D\ x)$ be the proof that $D$ is a mere
|
||||
proposition for all elements of $A$. Furthermore say we have a path
|
||||
between some two elements in $A$; $p \tp a_0 \equiv a_1$ then we can
|
||||
built a heterogeneous path between any two elements of $d_0 \tp
|
||||
D\ a_0$ and $d_1 \tp D\ a_1$.
|
||||
%
|
||||
$$
|
||||
\lemPropF\ \var{propD}\ p \tp \Path\ (\lambda\; i \mto D\ (p\ i))\ d_0\ d_1
|
||||
$$
|
||||
%
|
||||
Note that $d_0$ and $d_1$, though points of the same family, have
|
||||
different types. This is quite a mouthful, so let me try to show how
|
||||
this is a very general and useful result.
|
||||
|
||||
Often when proving equalities between elements of some dependent types
|
||||
$\lemPropF$ can be used to boil this complexity down to showing that
|
||||
the dependent parts of the type are mere propositions. For instance
|
||||
say we have a type:
|
||||
%
|
||||
$$
|
||||
T \defeq \sum_{a \tp A} D\ a
|
||||
$$
|
||||
%
|
||||
for some proposition $D \tp A \to \MCU$. That is we have $\var{propD}
|
||||
\tp \prod_{a \tp A} \isProp\ (D\ a)$. If we want to prove $t_0 \equiv
|
||||
t_1$ for two elements $t_0, t_1 \tp T$ then this will be a pair of
|
||||
paths:
|
||||
%
|
||||
%
|
||||
\begin{align*}
|
||||
p \tp & \fst\ t_0 \equiv \fst\ t_1 \\
|
||||
& \Path\ (\lambda\; i \to D\ (p\ i))\ (\snd\ t_0)\ (\snd\ t_1)
|
||||
\end{align*}
|
||||
%
|
||||
Here $\lemPropF$ directly allow us to prove the latter of these given
|
||||
that we have already provided $p$.
|
||||
%
|
||||
$$
|
||||
\lemPropF\ \var{propD}\ p
|
||||
\tp \Path\ (\lambda\; i \to D\ (p\ i))\ (\snd\ t_0)\ (\snd\ t_1)
|
||||
$$
|
||||
%
|
||||
\subsection{Functions over propositions}
|
||||
\label{sec:propPi}%
|
||||
$\prod$-types preserve propositionality when the co-domain is always a
|
||||
proposition.
|
||||
%
|
||||
$$
|
||||
\mathit{propPi} \tp \left(\prod_{a \tp A} \isProp\ (P\ a)\right) \to \isProp\ \left(\prod_{a \tp A} P\ a\right)
|
||||
$$
|
||||
\subsection{Pairs over propositions}
|
||||
\label{sec:propSig}
|
||||
%
|
||||
$\sum$-types preserve propositionality whenever its first component is
|
||||
a proposition and its second component is a proposition for all
|
||||
points of the left type.
|
||||
%
|
||||
$$
|
||||
\mathit{propSig} \tp \isProp\ A \to \left(\prod_{a \tp A} \isProp\ (P\ a)\right) \to \isProp\ \left(\sum_{a \tp A} P\ a\right)
|
||||
$$
|
||||
|
|
@ -0,0 +1,139 @@
|
|||
\chapter{Perspectives}
|
||||
\section{Discussion}
|
||||
In the previous chapter the practical aspects of proving things in
|
||||
Cubical Agda were highlighted. I also demonstrated the usefulness of
|
||||
separating ``laws'' from ``data''. One of the reasons for this is that
|
||||
dependencies within types can lead to very complicated goals. One
|
||||
technique for alleviating this was to prove that certain types are
|
||||
mere propositions.
|
||||
|
||||
\subsection{Computational properties}
|
||||
The new contribution of cubical Agda is that it has a constructive
|
||||
proof of functional extensionality\index{functional extensionality}
|
||||
and univalence\index{univalence}. This means in particular that the
|
||||
type checker can reduce terms defined with these theorems. One
|
||||
interesting result of this development is how much this influenced the
|
||||
development. In particular having a functional extensionality that
|
||||
``computes'' should simplify some proofs.
|
||||
|
||||
I have tested this by using a feature of Agda where one can mark
|
||||
certain bindings as being \emph{abstract}. This means that the
|
||||
type-checker will not try to reduce that term further during type
|
||||
checking. I tried making univalence and functional extensionality
|
||||
abstract. It turns out that the conversion behaviour of univalence is
|
||||
not used anywhere. For functional extensionality there are two places
|
||||
in the whole solution where the reduction behaviour is used to
|
||||
simplify some proofs. This is in showing that the maps between the
|
||||
two formulations of monads are inverses. See the notes in this
|
||||
module:
|
||||
%
|
||||
\begin{center}
|
||||
\sourcelink{Cat.Category.Monad.Voevodsky}
|
||||
\end{center}
|
||||
%
|
||||
|
||||
I will not reproduce it in full here as the type is quite involved. In
|
||||
stead I have put this in a source listing in
|
||||
\ref{app:abstract-funext}. The method used to find in what places the
|
||||
computational behaviour of these proofs are needed has the caveat of
|
||||
only working for places that directly or transitively uses these two
|
||||
proofs. Fortunately though the code is structured in such a way that
|
||||
this is the case. In conclusion the way I have structured these proofs
|
||||
means that the computational behaviour of functional extensionality
|
||||
and univalence has not been so relevant.
|
||||
|
||||
Barring this the computational behaviour of paths can still be useful.
|
||||
E.g.\ if a programmer wants to reuse functions that operate on a
|
||||
monoidal monads to work with a monad in the Kleisli form that the
|
||||
programmer has specified. To make this idea concrete, say we are
|
||||
given some function $f \tp \Kleisli \to T$, having a path between $p
|
||||
\tp \Monoidal \equiv \Kleisli$ induces a map $\coe\ p \tp \Monoidal
|
||||
\to \Kleisli$. We can compose $f$ with this map to get $f \comp
|
||||
\coe\ p \tp \Monoidal \to T$. Of course, since that map was
|
||||
constructed with an isomorphism, these maps already exist and could be
|
||||
used directly. So this is arguably only interesting when one also
|
||||
wants to prove properties of applying such functions.
|
||||
|
||||
\subsection{Reusability of proofs}
|
||||
The previous example illustrate how univalence unifies two otherwise
|
||||
disparate areas: The category-theoretic study of monads; and monads as
|
||||
in functional programming. Univalence thus allows one to reuse proofs.
|
||||
You could say that univalence gives the developer two proofs for the
|
||||
price of one. As an illustration of this I proved that monads are
|
||||
groupoids. I initially proved this for the Kleisli
|
||||
formulation\footnote{Actually doing this directly turned out to be
|
||||
tricky as well, so I defined an equivalent formulation which was not
|
||||
formulated with a record, but purely with $\sum$-types.}. Since the
|
||||
two formulations are equal under univalence, substitution directly
|
||||
gives us that this also holds for the monoidal formulation. This of
|
||||
course generalizes to any family $P \tp 𝒰 → 𝒰$ where $P$ is inhabited
|
||||
at either formulation (i.e.\ either $P\ \Monoidal$ or $P\ \Kleisli$
|
||||
holds).
|
||||
|
||||
The introduction (section \S\ref{sec:context}) mentioned that a
|
||||
typical way of getting access to functional extensionality is to work
|
||||
with setoids. Nowhere in this formalization has this been necessary,
|
||||
$\Path$ has been used globally in the project for propositional
|
||||
equality. One interesting place where this becomes apparent is in
|
||||
interfacing with the Agda standard library. Multiple definitions in
|
||||
the Agda standard library have been designed with the
|
||||
setoid-interpretation in mind. E.g.\ the notion of \emph{unique
|
||||
existential} is indexed by a relation that should play the role of
|
||||
propositional equality. Equivalence relations are likewise indexed,
|
||||
not only by the actual equivalence relation but also by another
|
||||
relation that serve as propositional equality.
|
||||
%% Unfortunately we cannot use the definition of equivalences found in
|
||||
%% the standard library to do equational reasoning directly. The
|
||||
%% reason for this is that the equivalence relation defined there must
|
||||
%% be a homogenous relation, but paths are heterogeneous relations.
|
||||
|
||||
In the formalization at present a significant amount of energy has
|
||||
been put towards proving things that would not have been needed in
|
||||
classical Agda. The proofs that some given type is a proposition were
|
||||
provided as a strategy to simplify some otherwise very complicated
|
||||
proofs (e.g.\ \ref{eq:proof-prop-IsPreCategory}
|
||||
and \ref{eq:productPath}). Often these proofs would not be this
|
||||
complicated. If the J-rule holds definitionally the proof-assistant
|
||||
can help simplify these goals considerably. The lack of the J-rule has
|
||||
a significant impact on the complexity of these kinds of proofs.
|
||||
|
||||
\subsection{Motifs}
|
||||
An oft-used technique in this development is using based path
|
||||
induction to prove certain properties. One particular challenge that
|
||||
arises when doing so is that Agda is not able to automatically infer
|
||||
the family that one wants to do induction over. For instance in the
|
||||
proof $\var{sym}\ (\var{sym}\ p) ≡ p$ from \ref{eq:sym-invol} the
|
||||
family that we chose to do induction over was $D\ b'\ p' \defeq
|
||||
\var{sym}\ (\var{sym}\ p') ≡ p'$. However, if one interactively tries
|
||||
to give this hole, all the information that Agda can provide is that
|
||||
one must provide an element of $𝒰$. Agda could be more helpful in this
|
||||
context, perhaps even infer this family in some situations. In this
|
||||
very simple example this is of course not a big problem, but there are
|
||||
examples in the source code where this gets more involved.
|
||||
|
||||
\section{Future work}
|
||||
\subsection{Compiling Cubical Agda}
|
||||
\label{sec:compiling-cubical-agda}
|
||||
Compilation of program written in Cubical Agda is currently not
|
||||
supported. One issue here is that the backends does not provide an
|
||||
implementation for the cubical primitives (such as the path-type).
|
||||
This means that even though the path-type gives us a computational
|
||||
interpretation of functional extensionality, univalence, transport,
|
||||
etc., we do not have a way of actually using this to compile our
|
||||
programs that use these primitives. It would be interesting to see
|
||||
practical applications of this.
|
||||
|
||||
\subsection{Proving laws of programs}
|
||||
Another interesting thing would be to use the Kleisli formulation of
|
||||
monads to prove properties of functional programs. The existence of
|
||||
univalence will make it possible to re-use proofs stated in terms of
|
||||
the monoidal formulation in this setting.
|
||||
|
||||
%% \subsection{Higher inductive types}
|
||||
%% This library has not explored the usefulness of higher inductive types
|
||||
%% in the context of Category Theory.
|
||||
|
||||
\subsection{Initiality conjecture}
|
||||
A fellow student at Chalmers, Andreas Källberg, is currently working
|
||||
on proving the initiality conjecture. He will be using this library
|
||||
to do so.
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
App. 2 in HoTT gives typing rule for pathJ including a computational
|
||||
rule for it.
|
||||
|
||||
If you have this computational rule definitionally, then you wouldn't
|
||||
need to use `pathJprop`.
|
||||
|
||||
In discussion-section I mention HITs. I should remove this or come up
|
||||
with a more elaborate example of something you could do, e.g.
|
||||
something with pushouts in the category of sets.
|
||||
|
|
@ -0,0 +1,72 @@
|
|||
Andrea Vezzosi <vezzosi@chalmers.se> Tue, Apr 24, 2018 at 2:02 PM
|
||||
To: Frederik Hanghøj Iversen <fhi.1990@gmail.com>
|
||||
Cc: Thierry Coquand <coquand@chalmers.se>
|
||||
On Tue, Apr 24, 2018 at 12:57 PM, Frederik Hanghøj Iversen
|
||||
<fhi.1990@gmail.com> wrote:
|
||||
> I've written the first few sections about my implementation. I was wondering
|
||||
> if you could have a quick look at it. You don't need to read it
|
||||
> word-for-word but I would like some indication from you if this is the sort
|
||||
> of thing you would like to see in the final report.
|
||||
|
||||
Yes! I would say this very much fits the bill of what the main part of
|
||||
the report should be, then you could have a discussion section where
|
||||
you might put some analysis of the pros and cons of cubical, design
|
||||
choices you made, and your experience overall.
|
||||
|
||||
I wonder if there should be some short introduction to Cubical Type
|
||||
Theory before this chapter, so you can introduce the Path type by
|
||||
itself and show some simple proof with it. e.g. how to get function
|
||||
extensionality.
|
||||
|
||||
You mention a few "combinators" like propPi and lemPropF, you might
|
||||
want to call them just lemmas, so it's clearer that these can be
|
||||
proven in --cubical.
|
||||
|
||||
>
|
||||
> I refer you specifically to "Chapter 2 - Implementation" on p. 6.
|
||||
>
|
||||
> In this chapter I plan to additionally include some text about the proof we
|
||||
> did that products are mere propositions and the proof about the two
|
||||
> equivalent notions of a monad.
|
||||
|
||||
I've read the chapter up until 2.3 and skimmed the rest for now, but I
|
||||
accumulated some editing suggestions I copy here.
|
||||
Remember to look for things like these when you proof-read the rest :)
|
||||
|
||||
|
||||
You should be careful to properly introduce things before you use
|
||||
them, like IsPreCategory (I'd prefer if it took the raw category as
|
||||
argument btw) and its fields isIdentity, isAssociative, .. come up a
|
||||
bit out of the blue from the end of page 8.
|
||||
Maybe the easiest is to show the definition of IsPreCategory.
|
||||
|
||||
Maybe give a type for propIsIdentity and mention the other prop* are similar.
|
||||
|
||||
Also the notation "isIdentity_a" to apply projections is a bit unusual
|
||||
so it needs to be introduced as well.
|
||||
To be fair it would be simpler to stick to function application
|
||||
(though I see that it would introduce more parentheses),
|
||||
|
||||
"The situation is a bit more complicated when we have a dependent
|
||||
type" could be more clear by being more specific:
|
||||
"The situation is a bit more complicated when the type of a field
|
||||
depends on a previous field"
|
||||
|
||||
Here too it might be more concrete if you also give the code for IsCategory.
|
||||
|
||||
In Path ( λ i → Univalent_{p i} ) isPreCategory_a isPreCategory_b
|
||||
I suggest parentheses around (p i), but also you should be consistent
|
||||
on whether you want to call the proof "p" or "p_{isPreCategory}",
|
||||
finally i'm guessing the two fields should be "isUnivalent" rather
|
||||
than "isPreCategory".
|
||||
|
||||
You can cite the book on the specific definition of isEquiv,
|
||||
"contractible fibers" in section 4.4, the grad lemma is also from
|
||||
somewhere but I don't remember off-hand.
|
||||
|
||||
You have not defined what you mean by _\~=_ and isomorphism.
|
||||
|
||||
|
||||
Cheers,
|
||||
Andrea
|
||||
[Quoted text hidden]
|
||||
|
|
@ -1,14 +1,14 @@
|
|||
\section{Halftime report}
|
||||
\chapter{Halftime report}
|
||||
I've written this as an appendix because 1) the aim of the thesis changed
|
||||
drastically from the planning report/proposal 2) partly I'm not sure how to
|
||||
structure my thesis.
|
||||
|
||||
My work so far has very much focused on the formalization, i.e. coding. It's
|
||||
My work so far has very much focused on the formalization, i.e.\ coding. It's
|
||||
unclear to me at this point what I should have in the final report. Here I will
|
||||
describe what I have managed to formalize so far and what outstanding challenges
|
||||
I'm facing.
|
||||
|
||||
\subsection{Implementation overview}
|
||||
\section{Implementation overview}
|
||||
The overall structure of my project is as follows:
|
||||
|
||||
\begin{itemize}
|
||||
|
|
@ -50,15 +50,15 @@ creating a function embodying the ``equality principle'' for a given record. In
|
|||
the case of monads, to prove two categories propositionally equal it enough to
|
||||
provide a proof that their data is equal.
|
||||
|
||||
\subsubsection{Categories}
|
||||
\subsection{Categories}
|
||||
Defines the basic notion of a category. This definition closely follows that of
|
||||
[HoTT]: That is, the standard definition of a category (data; objects, arrows,
|
||||
composition and identity, laws; preservation of identity and composition) plus
|
||||
the extra condition that it is univalent - namely that you can get an equality
|
||||
of two objects from an isomorphism.
|
||||
|
||||
I make no distinction between a pre-category and a real category (as in the
|
||||
[HoTT]-sense). A pre-category in my implementation would be a category sans the
|
||||
I make no distinction between a pre category and a real category (as in the
|
||||
[HoTT]-sense). A pre category in my implementation would be a category sans the
|
||||
witness to univalence.
|
||||
|
||||
I also prove that being a category is a proposition. This gives rise to an
|
||||
|
|
@ -69,30 +69,30 @@ shown that univalence holds for such a construction)
|
|||
|
||||
I also show that taking the opposite is an involution.
|
||||
|
||||
\subsubsection{Functors}
|
||||
\subsection{Functors}
|
||||
Defines the notion of a functor - also split up into data and laws.
|
||||
|
||||
Propositionality for being a functor.
|
||||
|
||||
Composition of functors and the identity functor.
|
||||
|
||||
\subsubsection{Products}
|
||||
\subsection{Products}
|
||||
Definition of what it means for an object to be a product in a given category.
|
||||
|
||||
Definition of what it means for a category to have all products.
|
||||
|
||||
\WIP Prove propositionality for being a product and having products.
|
||||
\WIP{} Prove propositionality for being a product and having products.
|
||||
|
||||
\subsubsection{Exponentials}
|
||||
\subsection{Exponentials}
|
||||
Definition of what it means to be an exponential object.
|
||||
|
||||
Definition of what it means for a category to have all exponential objects.
|
||||
|
||||
\subsubsection{Cartesian closed categories}
|
||||
\subsection{Cartesian closed categories}
|
||||
Definition of what it means for a category to be cartesian closed; namely that
|
||||
it has all products and all exponentials.
|
||||
|
||||
\subsubsection{Natural transformations}
|
||||
\subsection{Natural transformations}
|
||||
Definition of transformations\footnote{Maybe this is a name I made up for a
|
||||
family of morphisms} and the naturality condition for these.
|
||||
|
||||
|
|
@ -101,18 +101,18 @@ principle. Proof that natural transformations are homotopic sets.
|
|||
|
||||
The identity natural transformation.
|
||||
|
||||
\subsubsection{Yoneda embedding}
|
||||
\subsection{Yoneda embedding}
|
||||
|
||||
The yoneda embedding is typically presented in terms of the category of
|
||||
categories (cf. Awodey) \emph however this is not stricly needed - all we need
|
||||
is what would be the exponential object in that category - this happens to be
|
||||
functors and so this is how we define the yoneda embedding.
|
||||
|
||||
\subsubsection{Monads}
|
||||
\subsection{Monads}
|
||||
|
||||
Defines an equivalence between these two formulations of a monad:
|
||||
|
||||
\subsubsubsection{Monoidal monads}
|
||||
\subsubsection{Monoidal monads}
|
||||
|
||||
Defines the standard monoidal representation of a monad:
|
||||
|
||||
|
|
@ -121,7 +121,7 @@ and some laws about these natural transformations.
|
|||
|
||||
Propositionality proofs and equality principle is provided.
|
||||
|
||||
\subsubsubsection{Kleisli monads}
|
||||
\subsubsection{Kleisli monads}
|
||||
|
||||
A presentation of monads perhaps more familiar to a functional programer:
|
||||
|
||||
|
|
@ -130,28 +130,48 @@ some laws about these maps.
|
|||
|
||||
Propositionality proofs and equality principle is provided.
|
||||
|
||||
\subsubsubsection{Voevodsky's construction}
|
||||
\subsubsection{Voevodsky's construction}
|
||||
|
||||
Provides construction 2.3 as presented in an unpublished paper by the late
|
||||
Vladimir Voevodsky. This construction is similiar to the equivalence provided
|
||||
for the two preceding formulations
|
||||
Provides construction 2.3 as presented in an unpublished paper by Vladimir
|
||||
Voevodsky. This construction is similiar to the equivalence provided for the two
|
||||
preceding formulations
|
||||
\footnote{ TODO: I would like to include in the thesis some motivation for why
|
||||
this construction is particularly interesting.}
|
||||
|
||||
\subsubsection{Homotopy sets}
|
||||
\subsection{Homotopy sets}
|
||||
The typical category of sets where the objects are modelled by an Agda set
|
||||
(henceforth ``type'') at a given level is not a valid category in this cubical
|
||||
settings, we need to restrict the types to be those that are homotopy sets. Thus the objects of this category are:
|
||||
(henceforth ``$\Type$'') at a given level is not a valid category in this cubical
|
||||
settings, we need to restrict the types to be those that are homotopy sets. Thus
|
||||
the objects of this category are:
|
||||
%
|
||||
$$\Set_\ell \defeq \sum_{A \tp \MCU_\ell} \isSet\ A$$
|
||||
$$\hSet_\ell \defeq \sum_{A \tp \MCU_\ell} \isSet\ A$$
|
||||
%
|
||||
\WIP{} I'm still missing a few details for the proof that this category is
|
||||
univalent. Indeed this doesn't not follow immediately from
|
||||
The definition of univalence for categories I have defined is:
|
||||
%
|
||||
$$\mathit{univalence} \tp (A \cong B) \simeq (A \simeq B)$$
|
||||
$$\isEquiv\ (\hA \equiv \hB)\ (\hA \cong \hB)\ \idToIso$$
|
||||
%
|
||||
since $A$ and $B$ are of type $\MCU \neq \Set$.
|
||||
\subsubsection{Categories}
|
||||
Where $\hA and \hB$ denote objects in the category. Note that this is stronger
|
||||
than
|
||||
%
|
||||
$$(\hA \equiv \hB) \simeq (\hA \cong \hB)$$
|
||||
%
|
||||
Because we require that the equivalence is constructed from the witness to:
|
||||
%
|
||||
$$\id \comp f \equiv f \x f \comp \id \equiv f$$
|
||||
%
|
||||
And indeed univalence does not follow immediately from univalence for types:
|
||||
%
|
||||
$$(A \equiv B) \simeq (A \simeq B)$$
|
||||
%
|
||||
Because $A\ B \tp \Type$ whereas $\hA\ \hB \tp \hSet$.
|
||||
|
||||
For this reason I have shown that this category satisfies the following
|
||||
equivalent formulation of being univalent:
|
||||
%
|
||||
$$\prod_{A \tp hSet} \isContr \left( \sum_{X \tp hSet} A \cong X \right)$$
|
||||
%
|
||||
But I have not shown that it is indeed equivalent to my former definition.
|
||||
\subsection{Categories}
|
||||
Note that this category does in fact not exist. In stead I provide the
|
||||
definition of the ``raw'' category as well as some of the laws.
|
||||
|
||||
|
|
@ -162,16 +182,78 @@ These lemmas can be used to provide the actual exponential object in a context
|
|||
where we have a witness to this being a category. This is useful if this library
|
||||
is later extended to talk about higher categories.
|
||||
|
||||
\subsubsection{Functors}
|
||||
\subsection{Functors}
|
||||
The category of functors and natural transformations. An immediate corrolary is
|
||||
the set of presheaf categories.
|
||||
|
||||
\WIP{} I have not shown that the category of functors is univalent.
|
||||
|
||||
\subsubsection{Relations}
|
||||
The category of relations. \WIP I have not shown that this category is
|
||||
\subsection{Relations}
|
||||
The category of relations. \WIP{} I have not shown that this category is
|
||||
univalent. Not sure I intend to do so either.
|
||||
|
||||
\subsubsection{Free category}
|
||||
The free category of a category. \WIP I have not shown that this category is
|
||||
\subsection{Free category}
|
||||
The free category of a category. \WIP{} I have not shown that this category is
|
||||
univalent.
|
||||
|
||||
\section{Current Challenges}
|
||||
Besides the items marked \WIP{} above I still feel a bit unsure about what to
|
||||
include in my report. Most of my work so far has been specifically about
|
||||
developing this library. Some ideas:
|
||||
%
|
||||
\begin{itemize}
|
||||
\item
|
||||
Modularity properties
|
||||
\item
|
||||
Compare with setoid-approach to solve similiar problems.
|
||||
\item
|
||||
How to structure an implementation to best deal with types that have no
|
||||
structure (propositions) and those that do (sets and everything above)
|
||||
\end{itemize}
|
||||
%
|
||||
\section{Ideas for future developments}
|
||||
\subsection{Higher categories}
|
||||
I only have a notion of (1-)categories. Perhaps it would be nice to also
|
||||
formalize higher categories.
|
||||
|
||||
\subsection{Hierarchy of concepts related to monads}
|
||||
In Haskell the type-class Monad sits in a hierarchy atop the notion of a functor
|
||||
and applicative functors. There's probably a similiar notion in the
|
||||
category-theoretic approach to developing this.
|
||||
|
||||
As I have already defined monads from these two perspectives, it would be
|
||||
interesting to take this idea even further and actually show how monads are
|
||||
related to applicative functors and functors. I'm not entirely sure how this
|
||||
would look in Agda though.
|
||||
|
||||
\subsection{Use formulation on the standard library}
|
||||
I also thought it would be interesting to use this library to show certain
|
||||
properties about functors, applicative functors and monads used in the Agda
|
||||
Standard library. So I went ahead and tried to show that agda's standard
|
||||
library's notion of a functor (along with suitable laws) is equivalent to my
|
||||
formulation (in the category of homotopic sets). I ran into two problems here,
|
||||
however; the first one is that the standard library's notion of a functor is
|
||||
indexed by the object map:
|
||||
%
|
||||
$$
|
||||
\Functor \tp (\Type \to \Type) \to \Type
|
||||
$$
|
||||
%
|
||||
Where $\Functor\ F$ has the member:
|
||||
%
|
||||
$$
|
||||
\fmap \tp (A \to B) \to F A \to F B
|
||||
$$
|
||||
%
|
||||
Whereas the object map in my definition is existentially quantified:
|
||||
%
|
||||
$$
|
||||
\Functor \tp \Type
|
||||
$$
|
||||
%
|
||||
And $\Functor$ has these members:
|
||||
\begin{align*}
|
||||
F & \tp \Type \to \Type \\
|
||||
\fmap & \tp (A \to B) \to F A \to F B\}
|
||||
\end{align*}
|
||||
%
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,266 @@
|
|||
\chapter{Introduction}
|
||||
This thesis is a case study in the application of cubical Agda to the
|
||||
formalization of category theory. At the center of this is the notion
|
||||
of \nomenindex{equality}. There are two pervasive notions of equality
|
||||
in type theory: \nomenindex{judgmental equality} and
|
||||
\nomenindex{propositional equality}. Judgmental equality is a property
|
||||
of the type system. Propositional equality on the other hand is
|
||||
usually defined \emph{within} the system. When introducing
|
||||
definitions this report will use the symbol $\defeq$. Judgmental
|
||||
equalities will be denoted with $=$ and for propositional equalities
|
||||
the notation $\equiv$ is used.
|
||||
|
||||
The rules of judgmental equality are related with $β$- and
|
||||
$η$-reduction, which gives a notion of computation in a given type
|
||||
theory.
|
||||
%
|
||||
There are some properties that one usually want judgmental equality to
|
||||
satisfy. It must be \nomenindex{sound}, enjoy \nomenindex{canonicity}
|
||||
and be a \nomenindex{congruence relation}. Soundness means that things
|
||||
judged to be equal are equal with respects to the \nomenindex{model}
|
||||
of the theory or the \emph{meta theory}. It must be a congruence
|
||||
relation, because otherwise the relation certainly does not adhere to
|
||||
our notion of equality. E.g.\ One would be able to conclude things
|
||||
like: $x \equiv y \rightarrow f\ x \nequiv f\ y$. Canonicity means
|
||||
that any well typed term evaluates to a \emph{canonical} form. For
|
||||
example, for a closed term $e \tp \bN$, it will be the case that $e$
|
||||
reduces to $n$ applications of $\mathit{suc}$ to $0$ for some $n$;
|
||||
i.e.\ $e = \mathit{suc}^n\ 0$. Without canonicity terms in the
|
||||
language can get ``stuck'', meaning that they do not reduce to a
|
||||
canonical form.
|
||||
|
||||
For a system to work as a programming languages it is necessary for
|
||||
judgmental equality to be \nomenindex{decidable}. Being decidable
|
||||
simply means that that an algorithm exists to decide whether two terms
|
||||
are equal. For any practical implementation, the decidability must
|
||||
also be effectively computable.
|
||||
|
||||
For propositional equality the decidability requirement is relaxed. It
|
||||
is not in general possible to decide the correctness of logical
|
||||
propositions (cf.\ Hilbert's \emph{entscheidigungsproblem}).
|
||||
|
||||
There are two flavors of type-theory. \emph{Intensional-} and
|
||||
\emph{extensional-} type theory (ITT and ETT respectively). Identity
|
||||
types in extensional type theory are required to be
|
||||
\nomen{propositions}{proposition}. That is, a type with at most one
|
||||
inhabitant. In extensional type theory the principle of reflection
|
||||
%
|
||||
$$a ≡ b → a = b$$
|
||||
%
|
||||
is enough to make type checking undecidable. This report focuses on
|
||||
Agda, which at a glance can be thought of as a version of intensional
|
||||
type theory. Pattern-matching in regular Agda lets one prove
|
||||
\nomenindex{Uniqueness of Identity Proofs} (UIP). UIP states that any
|
||||
two identity proofs are propositionally identical.
|
||||
|
||||
The usual notion of propositional equality in ITT is quite
|
||||
restrictive. In the next section a few motivating examples will be
|
||||
presented that highlight. There exist techniques to circumvent these
|
||||
problems, as we shall see. This thesis will explore an extension to
|
||||
Agda that redefines the notion of propositional equality and as such
|
||||
is an alternative to these other techniques. The extension is called
|
||||
cubical Agda. Cubical Agda drops UIP, as it does not permit
|
||||
\nomenindex{functional extensionality} nor \nomenindex{univalence}.
|
||||
What makes cubical Agda particularly interesting is that it gives a
|
||||
\emph{constructive} interpretation of univalence. What all this means
|
||||
will be elaborated in the following sections.
|
||||
%
|
||||
\section{Motivating examples}
|
||||
%
|
||||
In the following two sections I present two examples that illustrate
|
||||
some limitations inherent in ITT and, by extension, Agda.
|
||||
%
|
||||
\subsection{Functional extensionality}
|
||||
\label{sec:functional-extensionality}%
|
||||
Consider the functions:
|
||||
%
|
||||
\begin{align*}%
|
||||
\var{zeroLeft} & \defeq λ\; (n \tp \bN) \to (0 + n \tp \bN) \\
|
||||
\var{zeroRight} & \defeq λ\; (n \tp \bN) \to (n + 0 \tp \bN)
|
||||
\end{align*}%
|
||||
%
|
||||
The term $n + 0$ is \nomenindex{definitionally} equal to $n$, which we
|
||||
write as $n + 0 = n$. This is also called \nomenindex{judgmental
|
||||
equality}. We call it definitional equality because the
|
||||
\emph{equality} arises from the \emph{definition} of $+$, which is:
|
||||
%
|
||||
\begin{align*}
|
||||
+ & \tp \bN \to \bN \to \bN \\
|
||||
n + 0 & \defeq n \\
|
||||
n + (\suc{m}) & \defeq \suc{(n + m)}
|
||||
\end{align*}
|
||||
%
|
||||
Note that $0 + n$ is \emph{not} definitionally equal to $n$. This is
|
||||
because $0 + n$ is in normal form. I.e.\ there is no rule for $+$
|
||||
whose left hand side matches this expression. We do, however, have that
|
||||
they are \nomen{propositionally}{propositional equality} equal, which
|
||||
we write as $n \equiv n + 0$. Propositional equality means that there
|
||||
is a proof that exhibits this relation. We can do induction over $n$
|
||||
to prove this:
|
||||
%
|
||||
\begin{align}
|
||||
\label{eq:zrn}
|
||||
\begin{split}
|
||||
\var{zrn}\ & \tp ∀ n → n ≡ \var{zeroRight}\ n \\
|
||||
\var{zrn}\ \var{zero} & \defeq \var{refl} \\
|
||||
\var{zrn}\ (\var{suc}\ n) & \defeq \var{cong}\ \var{suc}\ (\var{zrn}\ n)
|
||||
\end{split}
|
||||
\end{align}
|
||||
%
|
||||
This show that zero is a right neutral element (hence the name
|
||||
$\var{zrn}$). Since equality is a transitive relation we have that
|
||||
$\forall n \to \var{zeroLeft}\ n \equiv \var{zeroRight}\ n$.
|
||||
Unfortunately we don't have $\var{zeroLeft} \equiv \var{zeroRight}$.
|
||||
There is no way to construct a proof asserting the obvious equivalence
|
||||
of $\var{zeroLeft}$ and $\var{zeroRight}$. Actually showing this is
|
||||
outside the scope of this text. It would essentially involve giving a
|
||||
model for our type theory that validates all our axioms but where
|
||||
$\var{zeroLeft} \equiv \var{zeroRight}$ is not true. We cannot show
|
||||
that they are equal even though we can prove them equal for all
|
||||
points. This is exactly the notion of equality that we are interested
|
||||
in for functions: Functions are considered equal when they are equal
|
||||
for all inputs. This is called \nomenindex{pointwise equality} where
|
||||
\emph{points} of a function refer to its arguments.
|
||||
%
|
||||
\subsection{Equality of isomorphic types}
|
||||
%
|
||||
Let $\top$ denote the unit type -- a type with a single constructor.
|
||||
In the propositions as types interpretation of type theory $\top$ is
|
||||
the proposition that is always true. The type $A \x \top$ and $A$ has
|
||||
an element for each $a \tp A$. So in a sense they have the same shape
|
||||
(Greek; \nomenindex{isomorphic}). The second element of the pair does
|
||||
not add any ``interesting information''. It can be useful to identify
|
||||
such types. In fact it is quite commonplace in mathematics. Say we
|
||||
look at a set $\{x \mid \phi\ x \land \psi\ x\}$ and somehow conclude
|
||||
that $\psi\ x \equiv \top$ for all $x$. A mathematician would
|
||||
immediately conclude $\{x \mid \phi\ x \land \psi\ x\} \equiv \{x \mid
|
||||
\phi\ x\}$ without thinking twice. Unfortunately such an
|
||||
identification can not be performed in ITT.
|
||||
|
||||
More specifically what we are interested in is a way of identifying
|
||||
\nomenindex{equivalent} types. I will return to the definition of
|
||||
equivalence later in section \S\ref{sec:equiv}, but for now it is
|
||||
sufficient to think of an equivalence as a one-to-one correspondence.
|
||||
We write $A \simeq B$ to assert that $A$ and $B$ are equivalent types.
|
||||
The principle of univalence says that:
|
||||
%
|
||||
$$\mathit{univalence} \tp (A \simeq B) \simeq (A \equiv B)$$
|
||||
%
|
||||
In particular this allows us to construct an equality from an equivalence
|
||||
%
|
||||
$$\mathit{ua} \tp (A \simeq B) \to (A \equiv B)$$
|
||||
%
|
||||
and vice versa.
|
||||
|
||||
\section{Formalizing Category Theory}
|
||||
%
|
||||
The above examples serve to illustrate a limitation of ITT. One case
|
||||
where these limitations are particularly prohibitive is in the study
|
||||
of Category Theory. At a glance category theory can be described as
|
||||
``the mathematical study of (abstract) algebras of functions''
|
||||
(\cite{awodey-2006}). By that token functional extensionality is
|
||||
particularly useful for formulating Category Theory. In Category
|
||||
theory it is also commonplace to identify isomorphic structures.
|
||||
Univalence gives us a way to make this notion precise. In fact we can
|
||||
formulate this requirement within our formulation of categories by
|
||||
requiring the \emph{categories} themselves to be univalent as we shall
|
||||
see in section \S\ref{sec:univalence}.
|
||||
|
||||
\section{Context}
|
||||
\label{sec:context}
|
||||
%
|
||||
The idea of formalizing Category Theory in proof assistants is not new. There
|
||||
are a multitude of these available online. Notably:
|
||||
%
|
||||
\begin{itemize}
|
||||
\item
|
||||
A formalization in Agda using the setoid approach:
|
||||
\url{https://github.com/copumpkin/categories}
|
||||
\item
|
||||
A formalization in Agda with univalence and functional
|
||||
extensionality as postulates:
|
||||
\url{https://github.com/pcapriotti/agda-categories}
|
||||
\item
|
||||
A formalization in Coq in the homotopic setting:
|
||||
\url{https://github.com/HoTT/HoTT/tree/master/theories/Categories}
|
||||
\item
|
||||
A formalization in \emph{CubicalTT} -- a language designed for
|
||||
cubical type theory. Formalizes many different things, but only a
|
||||
few concepts from category theory:
|
||||
\url{https://github.com/mortberg/cubicaltt}
|
||||
\end{itemize}
|
||||
%
|
||||
The contribution of this thesis is to explore how working in a cubical
|
||||
setting will make it possible to prove more things, to reuse proofs
|
||||
and to compare some aspects of this formalization with the existing
|
||||
ones.
|
||||
|
||||
There are alternative approaches to working in a cubical setting where
|
||||
one can still have univalence and functional extensionality. One
|
||||
option is to postulate these as axioms. This approach, however, has
|
||||
other shortcomings, e.g.\ you lose \nomenindex{canonicity}
|
||||
(\cite[p.\ 3]{huber-2016}).
|
||||
|
||||
Another approach is to use the \emph{setoid interpretation} of type
|
||||
theory (\cite{hofmann-1995,huber-2016}). With this approach one works
|
||||
with \nomenindex{extensional sets} $(X, \sim)$. That is a type $X \tp
|
||||
\MCU$ and an equivalence relation $\sim\ \tp X \to X \to \MCU$ on that
|
||||
type. Under the setoid interpretation the equivalence relation serve
|
||||
as a sort of ``local'' propositional equality. Since the developer
|
||||
gets to pick this relation, it is not a~priori a congruence
|
||||
relation. It must be manually verified by the developer. Furthermore,
|
||||
functions between different setoids must be shown to be setoid
|
||||
homomorphism, that is; they preserve the relation.
|
||||
|
||||
This approach has other drawbacks: It does not satisfy all
|
||||
propositional equalities of type theory a~priori. That is, the
|
||||
developer must manually show that e.g.\ the relation is a congruence.
|
||||
Equational proofs $a \sim_{X} b$ are in some sense `local' to the
|
||||
extensional set $(X , \sim)$. To e.g.\ prove that $x ∼ y → f\ x ∼
|
||||
f\ y$ for some function $f \tp A → B$ between two extensional sets $A$
|
||||
and $B$ it must be shown that $f$ is a groupoid homomorphism. This
|
||||
makes it very cumbersome to work with in practice (\cite[p.
|
||||
4]{huber-2016}).
|
||||
|
||||
\section{Conventions}
|
||||
In the remainder of this thesis I will use the term \nomenindex{Type}
|
||||
to describe -- well -- types; thereby departing from the notation in
|
||||
Agda where the keyword \texttt{Set} refers to types.
|
||||
\nomenindex{Set}, on the other hand, shall refer to the homotopical
|
||||
notion of a set. I will also leave all universe levels implicit. This
|
||||
of course does not mean that a statement such as $\MCU \tp \MCU$ means
|
||||
that we have type-in-type but rather that the arguments to the
|
||||
universes are implicit.
|
||||
|
||||
I use the term \nomenindex{arrow} to refer to morphisms in a category,
|
||||
whereas the terms \nomenindex{morphism}, \nomenindex{map} or
|
||||
\nomenindex{function} shall be reserved for talking about type
|
||||
theoretic functions; i.e.\ functions in Agda.
|
||||
|
||||
As already noted $\defeq$ will be used for introducing definitions $=$
|
||||
will be used to for judgmental equality and $\equiv$ will be used for
|
||||
propositional equality.
|
||||
|
||||
All this is summarized in the following table:
|
||||
%
|
||||
\begin{samepage}
|
||||
\begin{center}
|
||||
\begin{tabular}{ c c c }
|
||||
Name & Agda & Notation \\
|
||||
\hline
|
||||
|
||||
\varindex{Type} & \texttt{Set} & $\Type$ \\
|
||||
|
||||
\varindex{Set} & \texttt{Σ Set IsSet} & $\Set$ \\
|
||||
Function, morphism, map & \texttt{A → B} & $A → B$ \\
|
||||
Dependent- ditto & \texttt{(a : A) → B} & $∏_{a \tp A} B$ \\
|
||||
|
||||
\varindex{Arrow} & \texttt{Arrow A B} & $\Arrow\ A\ B$ \\
|
||||
|
||||
\varindex{Object} & \texttt{C.Object} & $̱ℂ.Object$ \\
|
||||
Definition & \texttt{=} & $̱\defeq$ \\
|
||||
Judgmental equality & \null & $̱=$ \\
|
||||
Propositional equality & \null & $̱\equiv$
|
||||
\end{tabular}
|
||||
\end{center}
|
||||
\end{samepage}
|
||||
|
|
@ -0,0 +1,147 @@
|
|||
\newcommand{\subsubsubsection}[1]{\textbf{#1}}
|
||||
\newcommand{\WIP}{\textbf{WIP}}
|
||||
|
||||
\newcommand{\coloneqq}{\mathrel{\vcenter{\baselineskip0.5ex \lineskiplimit0pt
|
||||
\hbox{\scriptsize.}\hbox{\scriptsize.}}}%
|
||||
=}
|
||||
|
||||
\newcommand{\defeq}{\mathrel{\triangleq}}
|
||||
%% Alternatively:
|
||||
%% \newcommand{\defeq}{≔}
|
||||
\newcommand{\bN}{\mathbb{N}}
|
||||
\newcommand{\bC}{ℂ}
|
||||
\newcommand{\bD}{𝔻}
|
||||
\newcommand{\bX}{𝕏}
|
||||
% \newcommand{\to}{\rightarrow}
|
||||
%% \newcommand{\mto}{\mapsto}
|
||||
\newcommand{\mto}{\rightarrow}
|
||||
\newcommand{\UU}{\ensuremath{\mathcal{U}}\xspace}
|
||||
\let\type\UU
|
||||
\newcommand{\MCU}{\UU}
|
||||
\newcommand{\todo}[1]{\textit{#1}}
|
||||
\newcommand{\comp}{\circ}
|
||||
\newcommand{\x}{\times}
|
||||
\newcommand\inv[1]{#1\raisebox{1.15ex}{$\scriptscriptstyle-\!1$}}
|
||||
\newcommand{\tp}{\mathrel{:}}
|
||||
\newcommand{\Type}{\mathcal{U}}
|
||||
|
||||
\usepackage{graphicx}
|
||||
\makeatletter
|
||||
\newcommand{\shorteq}{%
|
||||
\settowidth{\@tempdima}{-}% Width of hyphen
|
||||
\resizebox{\@tempdima}{\height}{=}%
|
||||
}
|
||||
\makeatother
|
||||
\newcommand{\var}[1]{\ensuremath{\mathit{#1}}}
|
||||
\newcommand{\varindex}[1]{\ensuremath{\var{#1}}\index{$\var{#1}$}}
|
||||
\newcommand{\nomen}[2]{\emph{#1}\index{#2}}
|
||||
\newcommand{\nomenindex}[1]{\nomen{#1}{#1}}
|
||||
|
||||
\newcommand{\Hom}{\varindex{Hom}}
|
||||
\newcommand{\fmap}{\varindex{fmap}}
|
||||
\newcommand{\bind}{\varindex{bind}}
|
||||
\newcommand{\join}{\varindex{join}}
|
||||
\newcommand{\omap}{\varindex{omap}}
|
||||
\newcommand{\pure}{\varindex{pure}}
|
||||
\newcommand{\idFun}{\varindex{id}}
|
||||
\newcommand{\Sets}{\varindex{Sets}}
|
||||
\newcommand{\Set}{\varindex{Set}}
|
||||
\newcommand{\hSet}{\varindex{hSet}}
|
||||
\newcommand{\id}{\varindex{id}}
|
||||
\newcommand{\isEquiv}{\varindex{isEquiv}}
|
||||
\newcommand{\idToIso}{\varindex{idToIso}}
|
||||
\newcommand{\idIso}{\varindex{idIso}}
|
||||
\newcommand{\isSet}{\varindex{isSet}}
|
||||
\newcommand{\isContr}{\varindex{isContr}}
|
||||
\newcommand{\isGroupoid}{\varindex{isGroupoid}}
|
||||
\newcommand{\pathJ}{\varindex{pathJ}}
|
||||
\newcommand\Object{\varindex{Object}}
|
||||
\newcommand\Functor{\varindex{Functor}}
|
||||
\newcommand\isProp{\varindex{isProp}}
|
||||
\newcommand\propPi{\varindex{propPi}}
|
||||
\newcommand\propSig{\varindex{propSig}}
|
||||
\newcommand\PreCategory{\varindex{PreCategory}}
|
||||
\newcommand\IsPreCategory{\varindex{IsPreCategory}}
|
||||
\newcommand\isIdentity{\varindex{isIdentity}}
|
||||
\newcommand\propIsIdentity{\varindex{propIsIdentity}}
|
||||
\newcommand\IsCategory{\varindex{IsCategory}}
|
||||
\newcommand\Gl{\varindex{\lambda}}
|
||||
\newcommand\lemPropF{\varindex{lemPropF}}
|
||||
\newcommand\isPreCategory{\varindex{isPreCategory}}
|
||||
\newcommand\congruence{\varindex{cong}}
|
||||
\newcommand\identity{\varindex{identity}}
|
||||
\newcommand\isequiv{\varindex{isequiv}}
|
||||
\newcommand\qinv{\varindex{qinv}}
|
||||
\newcommand\fiber{\varindex{fiber}}
|
||||
\newcommand\shufflef{\varindex{shuffle}}
|
||||
\newcommand\Univalent{\varindex{Univalent}}
|
||||
\newcommand\refl{\varindex{refl}}
|
||||
\newcommand\isoToId{\varindex{isoToId}}
|
||||
\newcommand\Isomorphism{\varindex{Isomorphism}}
|
||||
\newcommand\rrr{\ggg}
|
||||
%% \newcommand\fish{\mathbin{↣}}
|
||||
%% \newcommand\fish{\mathbin{⤅}}
|
||||
\newcommand\fish{\mathbin{⤇}}
|
||||
%% \newcommand\fish{\mathbin{⤜}}
|
||||
%% \newcommand\fish{\mathrel{\wideoverbar{\rrr}}}
|
||||
\newcommand\fst{\varindex{fst}}
|
||||
\newcommand\snd{\varindex{snd}}
|
||||
\newcommand\Path{\varindex{Path}}
|
||||
\newcommand\Category{\varindex{Category}}
|
||||
\newcommand\TODO[1]{TODO: \emph{#1}}
|
||||
\newcommand*{\QED}{\hfill\ensuremath{\square}}%
|
||||
\newcommand\uexists{\exists!}
|
||||
\newcommand\Arrow{\varindex{Arrow}}
|
||||
\newcommand\embellish[1]{\widehat{#1}}
|
||||
\newcommand\nattrans[1]{\embellish{#1}}
|
||||
\newcommand\functor[1]{\embellish{#1}}
|
||||
\newcommand\NTsym{\varindex{NT}}
|
||||
\newcommand\NT[2]{\NTsym\ #1\ #2}
|
||||
\newcommand\Endo[1]{\varindex{Endo}\ #1}
|
||||
\newcommand\EndoR{\functor{\mathcal{R}}}
|
||||
\newcommand\omapR{\mathcal{R}}
|
||||
\newcommand\omapF{\mathcal{F}}
|
||||
\newcommand\omapG{\mathcal{G}}
|
||||
\newcommand\FunF{\functor{\omapF}}
|
||||
\newcommand\FunG{\functor{\omapG}}
|
||||
\newcommand\funExt{\varindex{funExt}}
|
||||
\newcommand{\suc}[1]{\varindex{suc}\ #1}
|
||||
\newcommand{\trans}{\varindex{trans}}
|
||||
\newcommand{\toKleisli}{\varindex{toKleisli}}
|
||||
\newcommand{\toMonoidal}{\varindex{toMonoidal}}
|
||||
\newcommand\pairA{\mathcal{A}}
|
||||
\newcommand\pairB{\mathcal{B}}
|
||||
\newcommand{\joinNT}{\functor{\varindex{join}}}
|
||||
\newcommand{\pureNT}{\functor{\varindex{pure}}}
|
||||
\newcommand{\hrefsymb}[2]{\href{#1}{#2 \ExternalLink}}
|
||||
\newcommand{\sourcebasepath}{http://web.student.chalmers.se/\textasciitilde hanghj/cat/doc/html/}
|
||||
\newcommand{\docbasepath}{https://github.com/fredefox/cat/}
|
||||
\newcommand{\sourcelink}[1]{\hrefsymb
|
||||
{\sourcebasepath#1.html}
|
||||
{\texttt{#1}}
|
||||
}
|
||||
\newcommand{\gitlink}{\hrefsymb{\docbasepath}{\texttt{\docbasepath}}}
|
||||
\newcommand{\doclink}{\hrefsymb{\sourcebasepath}{\texttt{\sourcebasepath}}}
|
||||
\newcommand{\clll}{\mathrel{\bC.\mathord{\lll}}}
|
||||
\newcommand{\dlll}{\mathrel{\bD.\mathord{\lll}}}
|
||||
\newcommand\coe{\varindex{coe}}
|
||||
\newcommand\Monoidal{\varindex{Monoidal}}
|
||||
\newcommand\Kleisli{\varindex{Kleisli}}
|
||||
\newcommand\I{\mathds{I}}
|
||||
|
||||
\makeatletter
|
||||
\DeclareRobustCommand\bigop[1]{%
|
||||
\mathop{\vphantom{\sum}\mathpalette\bigop@{#1}}\slimits@
|
||||
}
|
||||
\newcommand{\bigop@}[2]{%
|
||||
\vcenter{%
|
||||
\sbox\z@{$#1\sum$}%
|
||||
\hbox{\resizebox{\ifx#1\displaystyle.7\fi\dimexpr\ht\z@+\dp\z@}{!}{$\m@th#2$}}%
|
||||
}%
|
||||
}
|
||||
\makeatother
|
||||
|
||||
\renewcommand{\llll}{\mathbin{\bigop{\lll}}}
|
||||
\renewcommand{\rrrr}{\mathbin{\bigop{\rrr}}}
|
||||
%% \newcommand{\llll}{lll}
|
||||
%% \newcommand{\rrrr}{rrr}
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
\documentclass[a4paper]{report}
|
||||
%% \documentclass[tightpage]{preview}
|
||||
%% \documentclass[compact,a4paper]{article}
|
||||
|
||||
\input{packages.tex}
|
||||
\input{macros.tex}
|
||||
|
||||
\title{Univalent Categories}
|
||||
\author{Frederik Hanghøj Iversen}
|
||||
|
||||
%% \usepackage[
|
||||
%% subtitle=foo,
|
||||
%% author=Frederik Hanghøj Iversen,
|
||||
%% authoremail=hanghj@student.chalmers.se,
|
||||
%% newcommand=chalmers,=Chalmers University of Technology,
|
||||
%% supervisor=Thierry Coquand,
|
||||
%% supervisoremail=coquand@chalmers.se,
|
||||
%% supervisordepartment=chalmers,
|
||||
%% cosupervisor=Andrea Vezzosi,
|
||||
%% cosupervisoremail=vezzosi@chalmers.se,
|
||||
%% cosupervisordepartment=chalmers,
|
||||
%% examiner=Andreas Abel,
|
||||
%% examineremail=abela@chalmers.se,
|
||||
%% examinerdepartment=chalmers,
|
||||
%% institution=chalmers,
|
||||
%% department=Department of Computer Science and Engineering,
|
||||
%% researchgroup=Programming Logic Group
|
||||
%% ]{chalmerstitle}
|
||||
|
||||
\usepackage{chalmerstitle}
|
||||
\subtitle{A formalization of category theory in Cubical Agda}
|
||||
\authoremail{hanghj@student.chalmers.se}
|
||||
\newcommand{\chalmers}{Chalmers University of Technology and University of Gothenburg}
|
||||
\supervisor{Thierry Coquand}
|
||||
\supervisoremail{coquand@chalmers.se}
|
||||
\supervisordepartment{\chalmers}
|
||||
\cosupervisor{Andrea Vezzosi}
|
||||
\cosupervisoremail{vezzosi@chalmers.se}
|
||||
\cosupervisordepartment{\chalmers}
|
||||
\examiner{Andreas Abel}
|
||||
\examineremail{abela@chalmers.se}
|
||||
\examinerdepartment{\chalmers}
|
||||
\institution{\chalmers}
|
||||
\department{Department of Computer Science and Engineering}
|
||||
\researchgroup{Programming Logic Group}
|
||||
|
||||
\begin{document}
|
||||
|
||||
\frontmatter
|
||||
\myfrontmatter
|
||||
\maketitle
|
||||
\input{abstract.tex}
|
||||
\input{acknowledgements.tex}
|
||||
\tableofcontents
|
||||
\mainmatter
|
||||
%
|
||||
\input{introduction.tex}
|
||||
\input{cubical.tex}
|
||||
\input{implementation.tex}
|
||||
\input{discussion.tex}
|
||||
\input{conclusion.tex}
|
||||
|
||||
\nocite{cubical-demo}
|
||||
\nocite{coquand-2013}
|
||||
|
||||
\bibliography{refs}
|
||||
\begin{appendices}
|
||||
\setcounter{page}{1}
|
||||
\pagenumbering{roman}
|
||||
\input{appendix/abstract-funext.tex}
|
||||
%% \input{sources.tex}
|
||||
%% \input{planning.tex}
|
||||
%% \input{halftime.tex}
|
||||
\end{appendices}
|
||||
\printindex
|
||||
\end{document}
|
||||
|
|
@ -0,0 +1,151 @@
|
|||
\usepackage[utf8]{inputenc}
|
||||
|
||||
\usepackage{natbib}
|
||||
\bibliographystyle{plain}
|
||||
|
||||
\usepackage{xcolor}
|
||||
%% \mode<report>{
|
||||
\usepackage[
|
||||
%% hidelinks,
|
||||
pdfusetitle,
|
||||
pdfsubject={category theory},
|
||||
pdfkeywords={type theory, homotopy theory, category theory, agda}]
|
||||
{hyperref}
|
||||
%% }
|
||||
%% \definecolor{darkorange}{HTML}{ff8c00}
|
||||
%% \hypersetup{allbordercolors={darkorange}}
|
||||
\hypersetup{hidelinks}
|
||||
\usepackage{graphicx}
|
||||
%% \usepackage[active,tightpage]{preview}
|
||||
|
||||
\usepackage{parskip}
|
||||
\usepackage{multicol}
|
||||
\usepackage{amssymb,amsmath,amsthm,stmaryrd,mathrsfs,wasysym}
|
||||
\usepackage[toc,page]{appendix}
|
||||
\usepackage{xspace}
|
||||
\usepackage[paper=a4paper,top=3cm,bottom=3cm]{geometry}
|
||||
\usepackage{makeidx}
|
||||
\makeindex
|
||||
% \setlength{\parskip}{10pt}
|
||||
|
||||
% \usepackage{tikz}
|
||||
% \usetikzlibrary{arrows, decorations.markings}
|
||||
|
||||
% \usepackage{chngcntr}
|
||||
% \counterwithout{figure}{section}
|
||||
\numberwithin{equation}{section}
|
||||
|
||||
\usepackage{listings}
|
||||
\usepackage{fancyvrb}
|
||||
|
||||
\usepackage{mathpazo}
|
||||
\usepackage[scaled=0.95]{helvet}
|
||||
\usepackage{courier}
|
||||
\linespread{1.05} % Palatino looks better with this
|
||||
|
||||
\usepackage{lmodern}
|
||||
|
||||
\usepackage{enumerate}
|
||||
\usepackage{verbatim}
|
||||
|
||||
\usepackage{fontspec}
|
||||
\usepackage[light]{sourcecodepro}
|
||||
%% \setmonofont{Latin Modern Mono}
|
||||
%% \setmonofont[Mapping=tex-text]{FreeMono.otf}
|
||||
%% \setmonofont{FreeMono.otf}
|
||||
|
||||
|
||||
%% \pagestyle{fancyplain}
|
||||
\setlength{\headheight}{15pt}
|
||||
\renewcommand{\chaptermark}[1]{\markboth{\textsc{Chapter \thechapter. #1}}{}}
|
||||
\renewcommand{\sectionmark}[1]{\markright{\textsc{\thesection\ #1}}}
|
||||
|
||||
% Allows for the use of unicode-letters:
|
||||
\usepackage{unicode-math}
|
||||
|
||||
%% \RequirePackage{kvoptions}
|
||||
|
||||
\usepackage{pgffor}
|
||||
\lstset
|
||||
{basicstyle=\ttfamily
|
||||
,columns=fullflexible
|
||||
,breaklines=true
|
||||
,inputencoding=utf8
|
||||
,extendedchars=true
|
||||
%% ,literate={á}{{\'a}}1 {ã}{{\~a}}1 {é}{{\'e}}1
|
||||
}
|
||||
|
||||
\usepackage{newunicodechar}
|
||||
|
||||
%% \setmainfont{PT Serif}
|
||||
\newfontfamily{\fallbackfont}{FreeMono.otf}[Scale=MatchLowercase]
|
||||
%% \setmonofont[Mapping=tex-text]{FreeMono.otf}
|
||||
\DeclareTextFontCommand{\textfallback}{\fallbackfont}
|
||||
\newunicodechar{∨}{\textfallback{∨}}
|
||||
\newunicodechar{∧}{\textfallback{∧}}
|
||||
\newunicodechar{⊔}{\textfallback{⊔}}
|
||||
%% \newunicodechar{≊}{\textfallback{≊}}
|
||||
\newunicodechar{∈}{\textfallback{∈}}
|
||||
\newunicodechar{ℂ}{\textfallback{ℂ}}
|
||||
\newunicodechar{∘}{\textfallback{∘}}
|
||||
\newunicodechar{⟨}{\textfallback{⟨}}
|
||||
\newunicodechar{⟩}{\textfallback{⟩}}
|
||||
\newunicodechar{∎}{\textfallback{∎}}
|
||||
%% \newunicodechar{𝒜}{\textfallback{𝒜}}
|
||||
%% \newunicodechar{ℬ}{\textfallback{ℬ}}
|
||||
%% \newunicodechar{≊}{\textfallback{≊}}
|
||||
\makeatletter
|
||||
\newcommand*{\rom}[1]{\expandafter\@slowroman\romannumeral #1@}
|
||||
\makeatother
|
||||
\makeatletter
|
||||
|
||||
\newcommand\frontmatter{%
|
||||
\cleardoublepage
|
||||
%\@mainmatterfalse
|
||||
\pagenumbering{roman}}
|
||||
|
||||
\newcommand\mainmatter{%
|
||||
\cleardoublepage
|
||||
% \@mainmattertrue
|
||||
\pagenumbering{arabic}}
|
||||
|
||||
\newcommand\backmatter{%
|
||||
\if@openright
|
||||
\cleardoublepage
|
||||
\else
|
||||
\clearpage
|
||||
\fi
|
||||
% \@mainmatterfalse
|
||||
}
|
||||
|
||||
\makeatother
|
||||
\usepackage{xspace}
|
||||
\usepackage{tikz}
|
||||
\newcommand{\ExternalLink}{%
|
||||
\tikz[x=1.2ex, y=1.2ex, baseline=-0.05ex]{%
|
||||
\begin{scope}[x=1ex, y=1ex]
|
||||
\clip (-0.1,-0.1)
|
||||
--++ (-0, 1.2)
|
||||
--++ (0.6, 0)
|
||||
--++ (0, -0.6)
|
||||
--++ (0.6, 0)
|
||||
--++ (0, -1);
|
||||
\path[draw,
|
||||
line width = 0.5,
|
||||
rounded corners=0.5]
|
||||
(0,0) rectangle (1,1);
|
||||
\end{scope}
|
||||
\path[draw, line width = 0.5] (0.5, 0.5)
|
||||
-- (1, 1);
|
||||
\path[draw, line width = 0.5] (0.6, 1)
|
||||
-- (1, 1) -- (1, 0.6);
|
||||
}
|
||||
}
|
||||
\usepackage{ dsfont }
|
||||
|
||||
\usepackage{eso-pic}
|
||||
\newcommand{\backgroundpic}[3]{
|
||||
\put(#1,#2){
|
||||
\parbox[b][\paperheight]{\paperwidth}{
|
||||
\centering
|
||||
\includegraphics[width=\paperwidth,height=\paperheight,keepaspectratio]{#3}}}}
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
\section{Planning report}
|
||||
\chapter{Planning report}
|
||||
%
|
||||
I have already implemented multiple essential building blocks for a
|
||||
formalization of core-category theory. These concepts include:
|
||||
|
|
@ -0,0 +1,492 @@
|
|||
\documentclass[a4paper]{beamer}
|
||||
%% \documentclass[a4paper,handout]{beamer}
|
||||
%% \usecolortheme[named=seagull]{structure}
|
||||
|
||||
\input{packages.tex}
|
||||
|
||||
\input{macros.tex}
|
||||
|
||||
\title{Univalent Categories}
|
||||
\subtitle{A formalization of category theory in Cubical Agda}
|
||||
|
||||
\newcommand{\myname}{Frederik Hangh{\o}j Iversen}
|
||||
\author[\myname]{
|
||||
\myname\\
|
||||
\footnotesize Supervisors: Thierry Coquand, Andrea Vezzosi\\
|
||||
Examiner: Andreas Abel
|
||||
}
|
||||
\institute{Chalmers University of Technology}
|
||||
|
||||
\begin{document}
|
||||
|
||||
\frame{\titlepage}
|
||||
|
||||
\begin{frame}
|
||||
\frametitle{Introduction}
|
||||
Category Theory: The study of abstract functions. Slogan: ``It's the
|
||||
arrows that matter''\pause
|
||||
|
||||
Objects are equal ``up to isomorphism''. Univalence makes this notion
|
||||
precise.\pause
|
||||
|
||||
Agda does not permit proofs of univalence. Cubical Agda admits
|
||||
this.\pause
|
||||
|
||||
Goal: Construct a category whose terminal objects are (equivalent to)
|
||||
products. Use this to conclude that products are propositions, not a
|
||||
structure on a category.
|
||||
\end{frame}
|
||||
|
||||
\begin{frame}
|
||||
\frametitle{Outline}
|
||||
The path type
|
||||
|
||||
Definition of a (pre-) category
|
||||
|
||||
1-categories
|
||||
|
||||
Univalent (proper) categories
|
||||
|
||||
The category of spans
|
||||
\end{frame}
|
||||
|
||||
\section{Paths}
|
||||
\begin{frame}
|
||||
\frametitle{Paths}
|
||||
\framesubtitle{Definition}
|
||||
Heterogeneous paths
|
||||
\begin{equation*}
|
||||
\Path \tp (P \tp \I → \MCU) → P\ 0 → P\ 1 → \MCU
|
||||
\end{equation*}
|
||||
\pause
|
||||
For $P \tp \I → \MCU$ and $a_0 \tp P\ 0$, $a_1 \tp P\ 1$
|
||||
inhabitants of $\Path\ P\ a_0\ a_1$ are like functions
|
||||
%
|
||||
$$
|
||||
p \tp ∏_{i \tp \I} P\ i
|
||||
$$
|
||||
%
|
||||
Which satisfy $p\ 0 & = a_0$ and $p\ 1 & = a_1$
|
||||
\pause
|
||||
|
||||
Homogenous paths
|
||||
$$
|
||||
a_0 ≡ a_1 ≜ \Path\ (\var{const}\ A)\ a_0\ a_1
|
||||
$$
|
||||
\end{frame}
|
||||
|
||||
\begin{frame}
|
||||
\frametitle{Pre categories}
|
||||
\framesubtitle{Definition}
|
||||
Data:
|
||||
\begin{align*}
|
||||
\Object & \tp \Type \\
|
||||
\Arrow & \tp \Object → \Object → \Type \\
|
||||
\identity & \tp \Arrow\ A\ A \\
|
||||
\llll & \tp \Arrow\ B\ C → \Arrow\ A\ B → \Arrow\ A\ C
|
||||
\end{align*}
|
||||
%
|
||||
\pause
|
||||
Laws:
|
||||
%
|
||||
\begin{align*}
|
||||
\var{isAssociative} & \tp
|
||||
h \llll (g \llll f) ≡ (h \llll g) \llll f \\
|
||||
\var{isIdentity} & \tp
|
||||
(\identity \llll f ≡ f)
|
||||
×
|
||||
(f \llll \identity ≡ f)
|
||||
\end{align*}
|
||||
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Pre categories}
|
||||
\framesubtitle{1-categories}
|
||||
Cubical Agda does not admit \emph{Uniqueness of Identity Proofs}
|
||||
(UIP). Rather there is a hierarchy of \emph{Homotopy Types}:
|
||||
Contractible types, mere propositions, sets, groupoids, \dots
|
||||
|
||||
\pause
|
||||
1-categories:
|
||||
$$
|
||||
\isSet\ (\Arrow\ A\ B)
|
||||
$$
|
||||
\pause
|
||||
\begin{align*}
|
||||
\isSet & \tp \MCU → \MCU \\
|
||||
\isSet\ A & ≜ ∏_{a_0, a_1 \tp A} \isProp\ (a_0 ≡ a_1)
|
||||
\end{align*}
|
||||
\end{frame}
|
||||
|
||||
\begin{frame}
|
||||
\frametitle{Outline}
|
||||
The path type \ensuremath{\checkmark}
|
||||
|
||||
Definition of a (pre-) category \ensuremath{\checkmark}
|
||||
|
||||
1-categories \ensuremath{\checkmark}
|
||||
|
||||
Univalent (proper) categories
|
||||
|
||||
The category of spans
|
||||
\end{frame}
|
||||
|
||||
\begin{frame}
|
||||
\frametitle{Categories}
|
||||
\framesubtitle{Univalence}
|
||||
Let $\approxeq$ denote isomorphism of objects. We can then construct
|
||||
the identity isomorphism in any category:
|
||||
$$
|
||||
(\identity , \identity , \var{isIdentity}) \tp A \approxeq A
|
||||
$$
|
||||
\pause
|
||||
Likewise since paths are substitutive we can promote a path to an isomorphism:
|
||||
$$
|
||||
\idToIso \tp A ≡ B → A ≊ B
|
||||
$$
|
||||
\pause
|
||||
For a category to be univalent we require this to be an equivalence:
|
||||
%
|
||||
$$
|
||||
\isEquiv\ (A ≡ B)\ (A \approxeq B)\ \idToIso
|
||||
$$
|
||||
%
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Categories}
|
||||
\framesubtitle{Univalence, cont'd}
|
||||
$$\isEquiv\ (A ≡ B)\ (A \approxeq B)\ \idToIso$$
|
||||
\pause%
|
||||
$$(A ≡ B) ≃ (A \approxeq B)$$
|
||||
\pause%
|
||||
$$(A ≡ B) ≅ (A \approxeq B)$$
|
||||
\pause%
|
||||
Name the inverse of $\idToIso$:
|
||||
$$\isoToId \tp (A \approxeq B) → (A ≡ B)$$
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Propositionality of products}
|
||||
Construct a category for which it is the case that the terminal
|
||||
objects are equivalent to products:
|
||||
\begin{align*}
|
||||
\var{Terminal} ≃ \var{Product}\ ℂ\ 𝒜\ ℬ
|
||||
\end{align*}
|
||||
|
||||
\pause
|
||||
And since equivalences preserve homotopy levels we get:
|
||||
%
|
||||
$$
|
||||
\isProp\ \left(\var{Product}\ \bC\ 𝒜\ ℬ\right)
|
||||
$$
|
||||
\end{frame}
|
||||
|
||||
\begin{frame}
|
||||
\frametitle{Categories}
|
||||
\framesubtitle{A theorem}
|
||||
%
|
||||
Let the isomorphism $(ι, \inv{ι}, \var{inv}) \tp A \approxeq B$.
|
||||
%
|
||||
\pause
|
||||
%
|
||||
The isomorphism induces the path
|
||||
%
|
||||
$$
|
||||
p ≜ \isoToId\ (\iota, \inv{\iota}, \var{inv}) \tp A ≡ B
|
||||
$$
|
||||
%
|
||||
\pause
|
||||
and consequently a path on arrows:
|
||||
%
|
||||
$$
|
||||
p_{\var{dom}} ≜ \congruence\ (λ x → \Arrow\ x\ X)\ p
|
||||
\tp
|
||||
\Arrow\ A\ X ≡ \Arrow\ B\ X
|
||||
$$
|
||||
%
|
||||
\pause
|
||||
The proposition is:
|
||||
%
|
||||
\begin{align}
|
||||
\label{eq:coeDom}
|
||||
\tag{$\var{coeDom}$}
|
||||
∏_{f \tp A → X}
|
||||
\var{coe}\ p_{\var{dom}}\ f ≡ f \llll \inv{\iota}
|
||||
\end{align}
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Categories}
|
||||
\framesubtitle{A theorem, proof}
|
||||
\begin{align*}
|
||||
\var{coe}\ p_{\var{dom}}\ f
|
||||
& ≡ f \llll (\idToIso\ p)_1 && \text{By path-induction} \\
|
||||
& ≡ f \llll \inv{\iota}
|
||||
&& \text{$\idToIso$ and $\isoToId$ are inverses}\\
|
||||
\end{align*}
|
||||
\pause
|
||||
%
|
||||
Induction will be based at $A$. Let $\widetilde{B}$ and $\widetilde{p}
|
||||
\tp A ≡ \widetilde{B}$ be given.
|
||||
%
|
||||
\pause
|
||||
%
|
||||
Define the family:
|
||||
%
|
||||
$$
|
||||
D\ \widetilde{B}\ \widetilde{p} ≜
|
||||
\var{coe}\ \widetilde{p}_{\var{dom}}\ f
|
||||
≡
|
||||
f \llll \inv{(\idToIso\ \widetilde{p})}
|
||||
$$
|
||||
\pause
|
||||
%
|
||||
The base-case becomes:
|
||||
$$
|
||||
d \tp D\ A\ \refl =
|
||||
\left(\var{coe}\ \refl_{\var{dom}}\ f ≡ f \llll \inv{(\idToIso\ \refl)}\right)
|
||||
$$
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Categories}
|
||||
\framesubtitle{A theorem, proof, cont'd}
|
||||
$$
|
||||
d \tp
|
||||
\var{coe}\ \refl_{\var{dom}}\ f ≡ f \llll \inv{(\idToIso\ \refl)}
|
||||
$$
|
||||
\pause
|
||||
\begin{align*}
|
||||
\var{coe}\ \refl_{\var{dom}}\ f
|
||||
& =
|
||||
\var{coe}\ \refl\ f \\
|
||||
& ≡ f
|
||||
&& \text{neutral element for $\var{coe}$}\\
|
||||
& ≡ f \llll \identity \\
|
||||
& ≡ f \llll \var{subst}\ \refl\ \identity
|
||||
&& \text{neutral element for $\var{subst}$}\\
|
||||
& ≡ f \llll \inv{(\idToIso\ \refl)}
|
||||
&& \text{By definition of $\idToIso$}\\
|
||||
\end{align*}
|
||||
\pause
|
||||
In conclusion, the theorem is inhabited by:
|
||||
$$
|
||||
\var{pathInd}\ D\ d\ B\ p
|
||||
$$
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Span category} \framesubtitle{Definition} Given a base
|
||||
category $\bC$ and two objects in this category $\pairA$ and $\pairB$
|
||||
we can construct the \nomenindex{span category}:
|
||||
%
|
||||
\pause
|
||||
Objects:
|
||||
$$
|
||||
∑_{X \tp Object} (\Arrow\ X\ \pairA) × (\Arrow\ X\ \pairB)
|
||||
$$
|
||||
\pause
|
||||
%
|
||||
Arrows between objects $(A , a_{\pairA} , a_{\pairB})$ and
|
||||
$(B , b_{\pairA} , b_{\pairB})$:
|
||||
%
|
||||
$$
|
||||
∑_{f \tp \Arrow\ A\ B}
|
||||
(b_{\pairA} \llll f ≡ a_{\pairA}) ×
|
||||
(b_{\pairB} \llll f ≡ a_{\pairB})
|
||||
$$
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Span category}
|
||||
\framesubtitle{Univalence}
|
||||
\begin{align*}
|
||||
(X , x_{𝒜} , x_{ℬ}) ≡ (Y , y_{𝒜} , y_{ℬ})
|
||||
\end{align*}
|
||||
\begin{align*}
|
||||
\begin{split}
|
||||
p \tp & X ≡ Y \\
|
||||
& \Path\ (λ i → \Arrow\ (p\ i)\ 𝒜)\ x_{𝒜}\ y_{𝒜} \\
|
||||
& \Path\ (λ i → \Arrow\ (p\ i)\ ℬ)\ x_{ℬ}\ y_{ℬ}
|
||||
\end{split}
|
||||
\end{align*}
|
||||
\begin{align*}
|
||||
\begin{split}
|
||||
\var{iso} \tp & X \approxeq Y \\
|
||||
& \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ 𝒜)\ x_{𝒜}\ y_{𝒜} \\
|
||||
& \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ ℬ)\ x_{ℬ}\ y_{ℬ}
|
||||
\end{split}
|
||||
\end{align*}
|
||||
\begin{align*}
|
||||
(X , x_{𝒜} , x_{ℬ}) ≊ (Y , y_{𝒜} , y_{ℬ})
|
||||
\end{align*}
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Span category}
|
||||
\framesubtitle{Univalence, proof}
|
||||
%
|
||||
\begin{align*}
|
||||
%% (f, \inv{f}, \var{inv}_f, \var{inv}_{\inv{f}})
|
||||
%% \tp
|
||||
(X, x_{𝒜}, x_{ℬ}) \approxeq (Y, y_{𝒜}, y_{ℬ})
|
||||
\to
|
||||
\begin{split}
|
||||
\var{iso} \tp & X \approxeq Y \\
|
||||
& \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ 𝒜)\ x_{𝒜}\ y_{𝒜} \\
|
||||
& \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ ℬ)\ x_{ℬ}\ y_{ℬ}
|
||||
\end{split}
|
||||
\end{align*}
|
||||
\pause
|
||||
%
|
||||
Let $(f, \inv{f}, \var{inv}_f, \var{inv}_{\inv{f}})$ be an inhabitant
|
||||
of the antecedent.\pause
|
||||
|
||||
Projecting out the first component gives us the isomorphism
|
||||
%
|
||||
$$
|
||||
(\fst\ f, \fst\ \inv{f}
|
||||
, \congruence\ \fst\ \var{inv}_f
|
||||
, \congruence\ \fst\ \var{inv}_{\inv{f}}
|
||||
)
|
||||
\tp X \approxeq Y
|
||||
$$
|
||||
\pause
|
||||
%
|
||||
This gives rise to the following paths:
|
||||
%
|
||||
\begin{align*}
|
||||
\begin{split}
|
||||
\widetilde{p} & \tp X ≡ Y \\
|
||||
\widetilde{p}_{𝒜} & \tp \Arrow\ X\ 𝒜 ≡ \Arrow\ Y\ 𝒜 \\
|
||||
\end{split}
|
||||
\end{align*}
|
||||
%
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Span category}
|
||||
\framesubtitle{Univalence, proof, cont'd}
|
||||
It remains to construct:
|
||||
%
|
||||
\begin{align*}
|
||||
\begin{split}
|
||||
& \Path\ (λ i → \widetilde{p}_{𝒜}\ i)\ x_{𝒜}\ y_{𝒜}
|
||||
\end{split}
|
||||
\end{align*}
|
||||
\pause
|
||||
%
|
||||
This is achieved with the following lemma:
|
||||
%
|
||||
\begin{align*}
|
||||
∏_{q \tp A ≡ B} \var{coe}\ q\ x_{𝒜} ≡ y_{𝒜}
|
||||
→
|
||||
\Path\ (λ i → q\ i)\ x_{𝒜}\ y_{𝒜}
|
||||
\end{align*}
|
||||
%
|
||||
Which is used without proof.\pause
|
||||
|
||||
So the construction reduces to:
|
||||
%
|
||||
\begin{align*}
|
||||
\var{coe}\ \widetilde{p}_{𝒜}\ x_{𝒜} ≡ y_{𝒜}
|
||||
\end{align*}%
|
||||
\pause%
|
||||
This is proven with:
|
||||
%
|
||||
\begin{align*}
|
||||
\var{coe}\ \widetilde{p}_{𝒜}\ x_{𝒜}
|
||||
& ≡ x_{𝒜} \llll \fst\ \inv{f} && \text{\ref{eq:coeDom}} \\
|
||||
& ≡ y_{𝒜} && \text{Property of span category}
|
||||
\end{align*}
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Propositionality of products}
|
||||
We have
|
||||
%
|
||||
$$
|
||||
\isProp\ \var{Terminal}
|
||||
$$\pause
|
||||
%
|
||||
We can show:
|
||||
\begin{align*}
|
||||
\var{Terminal} ≃ \var{Product}\ ℂ\ 𝒜\ ℬ
|
||||
\end{align*}
|
||||
\pause
|
||||
And since equivalences preserve homotopy levels we get:
|
||||
%
|
||||
$$
|
||||
\isProp\ \left(\var{Product}\ \bC\ 𝒜\ ℬ\right)
|
||||
$$
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Monads}
|
||||
\framesubtitle{Monoidal form}
|
||||
%
|
||||
\begin{align*}
|
||||
\EndoR & \tp \Functor\ ℂ\ ℂ \\
|
||||
\pureNT
|
||||
& \tp \NT{\widehat{\identity}}{\EndoR} \\
|
||||
\joinNT
|
||||
& \tp \NT{(\EndoR \oplus \EndoR)}{\EndoR}
|
||||
\end{align*}
|
||||
\pause
|
||||
%
|
||||
Let $\fmap$ be the map on arrows of $\EndoR$.
|
||||
%
|
||||
\begin{align*}
|
||||
\join \llll \fmap\ \join
|
||||
& ≡ \join \llll \join \\
|
||||
\join \llll \pure\ & ≡ \identity \\
|
||||
\join \llll \fmap\ \pure & ≡ \identity
|
||||
\end{align*}
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Monads}
|
||||
\framesubtitle{Kleisli form}
|
||||
%
|
||||
\begin{align*}
|
||||
\omapR & \tp \Object → \Object \\
|
||||
\pure & \tp % ∏_{X \tp Object}
|
||||
\Arrow\ X\ (\omapR\ X) \\
|
||||
\bind & \tp
|
||||
\Arrow\ X\ (\omapR\ Y)
|
||||
\to
|
||||
\Arrow\ (\omapR\ X)\ (\omapR\ Y)
|
||||
\end{align*}\pause
|
||||
%
|
||||
\begin{align*}
|
||||
\fish & \tp
|
||||
\Arrow\ A\ (\omapR\ B)
|
||||
→
|
||||
\Arrow\ B\ (\omapR\ C)
|
||||
→
|
||||
\Arrow\ A\ (\omapR\ C) \\
|
||||
f \fish g & ≜ f \rrrr (\bind\ g)
|
||||
\end{align*}
|
||||
\pause
|
||||
%
|
||||
\begin{align*}
|
||||
\bind\ \pure & ≡ \identity_{\omapR\ X} \\
|
||||
\pure \fish f & ≡ f \\
|
||||
(\bind\ f) \rrrr (\bind\ g) & ≡ \bind\ (f \fish g)
|
||||
\end{align*}
|
||||
\end{frame}
|
||||
\begin{frame}
|
||||
\frametitle{Monads}
|
||||
\framesubtitle{Equivalence}
|
||||
In the monoidal formulation we can define $\bind$:
|
||||
%
|
||||
$$
|
||||
\bind\ f ≜ \join \llll \fmap\ f
|
||||
$$
|
||||
\pause
|
||||
%
|
||||
And likewise in the Kleisli formulation we can define $\join$:
|
||||
%
|
||||
$$
|
||||
\join ≜ \bind\ \identity
|
||||
$$
|
||||
\pause
|
||||
The laws are logically equivalent. Since logical equivalence is
|
||||
enough for as an equivalence of types for propositions we get:
|
||||
%
|
||||
$$
|
||||
\var{Monoidal} ≃ \var{Kleisli}
|
||||
$$
|
||||
%
|
||||
\end{frame}
|
||||
\end{document}
|
||||
|
|
@ -106,9 +106,15 @@
|
|||
@MISC{mo-formalizations,
|
||||
TITLE = {Formalizations of category theory in proof assistants},
|
||||
AUTHOR = {Jason Gross},
|
||||
HOWPUBLISHED = {MathOverflow},
|
||||
NOTE = {Version: 2014-01-19},
|
||||
year={2014},
|
||||
EPRINT = {\url{https://mathoverflow.net/q/152497}},
|
||||
URL = {https://mathoverflow.net/q/152497}
|
||||
url = {https://mathoverflow.net/q/152497},
|
||||
howpublished = {MathOverflow: \url{https://mathoverflow.net/q/152497}}
|
||||
}
|
||||
@Misc{UniMath,
|
||||
author = {Voevodsky, Vladimir and Ahrens, Benedikt and Grayson, Daniel and others},
|
||||
title = {{UniMath --- a computer-checked library of univalent mathematics}},
|
||||
url = {https://github.com/UniMath/UniMath},
|
||||
howpublished = {{available} at \url{https://github.com/UniMath/UniMath}}
|
||||
}
|
||||
|
|
@ -0,0 +1,429 @@
|
|||
\chapter{Source code excerpts}
|
||||
\label{ch:app-sources}
|
||||
In the following a few of the definitions mentioned in the report are included.
|
||||
The following is \emph{not} a verbatim copy of individual modules from the
|
||||
implementation. Rather, this is a redacted and pre-formatted designed for
|
||||
presentation purposes. Its provided here as a convenience. The actual sources
|
||||
are the only authoritative source. Is something is not clear, please refer to
|
||||
those.
|
||||
\section{Cubical}
|
||||
\label{sec:app-cubical}
|
||||
\begin{figure}[h]
|
||||
\label{fig:path}
|
||||
\begin{Verbatim}
|
||||
postulate
|
||||
PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ
|
||||
|
||||
module _ {ℓ} {A : Set ℓ} where
|
||||
_≡_ : A → A → Set ℓ
|
||||
_≡_ {A = A} = PathP (λ _ → A)
|
||||
|
||||
refl : {x : A} → x ≡ x
|
||||
refl {x = x} = λ _ → x
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from the cubical library. Definition of the path-type.}
|
||||
\end{figure}
|
||||
\clearpage
|
||||
%
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module _ {ℓ : Level} (A : Set ℓ) where
|
||||
isContr : Set ℓ
|
||||
isContr = Σ[ x ∈ A ] (∀ y → x ≡ y)
|
||||
|
||||
isProp : Set ℓ
|
||||
isProp = (x y : A) → x ≡ y
|
||||
|
||||
isSet : Set ℓ
|
||||
isSet = (x y : A) → (p q : x ≡ y) → p ≡ q
|
||||
|
||||
isGrpd : Set ℓ
|
||||
isGrpd = (x y : A) → (p q : x ≡ y) → (a b : p ≡ q) → a ≡ b
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from the cubical library. Definition of the first few
|
||||
homotopy-levels.}
|
||||
\end{figure}
|
||||
%
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module _ {ℓ ℓ'} {A : Set ℓ} {x : A}
|
||||
(P : ∀ y → x ≡ y → Set ℓ') (d : P x ((λ i → x))) where
|
||||
pathJ : (y : A) → (p : x ≡ y) → P y p
|
||||
pathJ _ p = transp (λ i → uncurry P (contrSingl p i)) d
|
||||
\end{Verbatim}
|
||||
\clearpage
|
||||
\caption{Excerpt from the cubical library. Definition of based path-induction.}
|
||||
\end{figure}
|
||||
%
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module _ {ℓ ℓ'} {A : Set ℓ} {B : A → Set ℓ'} where
|
||||
propPi : (h : (x : A) → isProp (B x)) → isProp ((x : A) → B x)
|
||||
propPi h f0 f1 = λ i → λ x → (h x (f0 x) (f1 x)) i
|
||||
|
||||
lemPropF : (P : (x : A) → isProp (B x)) {a0 a1 : A}
|
||||
(p : a0 ≡ a1) {b0 : B a0} {b1 : B a1} → PathP (λ i → B (p i)) b0 b1
|
||||
lemPropF P p {b0} {b1} = λ i → P (p i)
|
||||
(primComp (λ j → B (p (i ∧ j)) ) (~ i) (λ _ → λ { (i = i0) → b0 }) b0)
|
||||
(primComp (λ j → B (p (i ∨ ~ j)) ) (i) (λ _ → λ{ (i = i1) → b1 }) b1) i
|
||||
|
||||
lemSig : (pB : (x : A) → isProp (B x))
|
||||
(u v : Σ A B) (p : fst u ≡ fst v) → u ≡ v
|
||||
lemSig pB u v p = λ i → (p i) , ((lemPropF pB p) {snd u} {snd v} i)
|
||||
|
||||
propSig : (pA : isProp A) (pB : (x : A) → isProp (B x)) → isProp (Σ A B)
|
||||
propSig pA pB t u = lemSig pB t u (pA (fst t) (fst u))
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from the cubical library. A few combinators.}
|
||||
\end{figure}
|
||||
\clearpage
|
||||
\section{Categories}
|
||||
\label{sec:app-categories}
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
field
|
||||
Object : Set ℓa
|
||||
Arrow : Object → Object → Set ℓb
|
||||
identity : {A : Object} → Arrow A A
|
||||
_<<<_ : {A B C : Object} → Arrow B C → Arrow A B → Arrow A C
|
||||
|
||||
_>>>_ : {A B C : Object} → (Arrow A B) → (Arrow B C) → Arrow A C
|
||||
f >>> g = g <<< f
|
||||
|
||||
IsAssociative : Set (ℓa ⊔ ℓb)
|
||||
IsAssociative = ∀ {A B C D} {f : Arrow A B} {g : Arrow B C} {h : Arrow C D}
|
||||
→ h <<< (g <<< f) ≡ (h <<< g) <<< f
|
||||
|
||||
IsIdentity : ({A : Object} → Arrow A A) → Set (ℓa ⊔ ℓb)
|
||||
IsIdentity id = {A B : Object} {f : Arrow A B}
|
||||
→ id <<< f ≡ f × f <<< id ≡ f
|
||||
|
||||
ArrowsAreSets : Set (ℓa ⊔ ℓb)
|
||||
ArrowsAreSets = ∀ {A B : Object} → isSet (Arrow A B)
|
||||
|
||||
IsInverseOf : ∀ {A B} → (Arrow A B) → (Arrow B A) → Set ℓb
|
||||
IsInverseOf = λ f g → g <<< f ≡ identity × f <<< g ≡ identity
|
||||
|
||||
Isomorphism : ∀ {A B} → (f : Arrow A B) → Set ℓb
|
||||
Isomorphism {A} {B} f = Σ[ g ∈ Arrow B A ] IsInverseOf f g
|
||||
|
||||
_≊_ : (A B : Object) → Set ℓb
|
||||
_≊_ A B = Σ[ f ∈ Arrow A B ] (Isomorphism f)
|
||||
|
||||
IsTerminal : Object → Set (ℓa ⊔ ℓb)
|
||||
IsTerminal T = {X : Object} → isContr (Arrow X T)
|
||||
|
||||
Terminal : Set (ℓa ⊔ ℓb)
|
||||
Terminal = Σ Object IsTerminal
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category}. The definition of a category.}
|
||||
\end{figure}
|
||||
\clearpage
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module Univalence (isIdentity : IsIdentity identity) where
|
||||
idIso : (A : Object) → A ≊ A
|
||||
idIso A = identity , identity , isIdentity
|
||||
|
||||
idToIso : (A B : Object) → A ≡ B → A ≊ B
|
||||
idToIso A B eq = subst eq (idIso A)
|
||||
|
||||
Univalent : Set (ℓa ⊔ ℓb)
|
||||
Univalent = {A B : Object} → isEquiv (A ≡ B) (A ≊ B) (idToIso A B)
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category}. Continued from previous. Definition of univalence.}
|
||||
\end{figure}
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module _ {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where
|
||||
record IsPreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
open RawCategory ℂ public
|
||||
field
|
||||
isAssociative : IsAssociative
|
||||
isIdentity : IsIdentity identity
|
||||
arrowsAreSets : ArrowsAreSets
|
||||
open Univalence isIdentity public
|
||||
|
||||
record PreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
field
|
||||
isPreCategory : IsPreCategory
|
||||
open IsPreCategory isPreCategory public
|
||||
|
||||
record IsCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
field
|
||||
isPreCategory : IsPreCategory
|
||||
open IsPreCategory isPreCategory public
|
||||
field
|
||||
univalent : Univalent
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category}. Records with inhabitants for
|
||||
the laws defined in the previous listings.}
|
||||
\end{figure}
|
||||
\clearpage
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module Opposite {ℓa ℓb : Level} where
|
||||
module _ (ℂ : Category ℓa ℓb) where
|
||||
private
|
||||
module _ where
|
||||
module ℂ = Category ℂ
|
||||
opRaw : RawCategory ℓa ℓb
|
||||
RawCategory.Object opRaw = ℂ.Object
|
||||
RawCategory.Arrow opRaw = flip ℂ.Arrow
|
||||
RawCategory.identity opRaw = ℂ.identity
|
||||
RawCategory._<<<_ opRaw = ℂ._>>>_
|
||||
|
||||
open RawCategory opRaw
|
||||
|
||||
isPreCategory : IsPreCategory opRaw
|
||||
IsPreCategory.isAssociative isPreCategory = sym ℂ.isAssociative
|
||||
IsPreCategory.isIdentity isPreCategory = swap ℂ.isIdentity
|
||||
IsPreCategory.arrowsAreSets isPreCategory = ℂ.arrowsAreSets
|
||||
|
||||
open IsPreCategory isPreCategory
|
||||
|
||||
----------------------------
|
||||
-- NEXT LISTING GOES HERE --
|
||||
----------------------------
|
||||
|
||||
isCategory : IsCategory opRaw
|
||||
IsCategory.isPreCategory isCategory = isPreCategory
|
||||
IsCategory.univalent isCategory
|
||||
= univalenceFromIsomorphism (isoToId* , inv)
|
||||
|
||||
opposite : Category ℓa ℓb
|
||||
Category.raw opposite = opRaw
|
||||
Category.isCategory opposite = isCategory
|
||||
|
||||
module _ {ℂ : Category ℓa ℓb} where
|
||||
open Category ℂ
|
||||
private
|
||||
rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw
|
||||
RawCategory.Object (rawInv _) = Object
|
||||
RawCategory.Arrow (rawInv _) = Arrow
|
||||
RawCategory.identity (rawInv _) = identity
|
||||
RawCategory._<<<_ (rawInv _) = _<<<_
|
||||
|
||||
oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ
|
||||
oppositeIsInvolution = Category≡ rawInv
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category}. Showing that the opposite
|
||||
category is a category. Part of this listing has been cut out and placed in
|
||||
the next listing.}
|
||||
\end{figure}
|
||||
\clearpage
|
||||
For reasons of formatting the following listing is continued from the above with
|
||||
fewer levels of indentation.
|
||||
%
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module _ {A B : ℂ.Object} where
|
||||
open Σ (toIso _ _ (ℂ.univalent {A} {B}))
|
||||
renaming (fst to idToIso* ; snd to inv*)
|
||||
open AreInverses {f = ℂ.idToIso A B} {idToIso*} inv*
|
||||
|
||||
shuffle : A ≊ B → A ℂ.≊ B
|
||||
shuffle (f , g , inv) = g , f , inv
|
||||
|
||||
shuffle~ : A ℂ.≊ B → A ≊ B
|
||||
shuffle~ (f , g , inv) = g , f , inv
|
||||
|
||||
isoToId* : A ≊ B → A ≡ B
|
||||
isoToId* = idToIso* ∘ shuffle
|
||||
|
||||
inv : AreInverses (idToIso A B) isoToId*
|
||||
inv =
|
||||
( funExt (λ x → begin
|
||||
(isoToId* ∘ idToIso A B) x
|
||||
≡⟨⟩
|
||||
(idToIso* ∘ shuffle ∘ idToIso A B) x
|
||||
≡⟨ cong (λ φ → φ x)
|
||||
(cong (λ φ → idToIso* ∘ shuffle ∘ φ) (funExt (isoEq refl))) ⟩
|
||||
(idToIso* ∘ shuffle ∘ shuffle~ ∘ ℂ.idToIso A B) x
|
||||
≡⟨⟩
|
||||
(idToIso* ∘ ℂ.idToIso A B) x
|
||||
≡⟨ (λ i → verso-recto i x) ⟩
|
||||
x ∎)
|
||||
, funExt (λ x → begin
|
||||
(idToIso A B ∘ idToIso* ∘ shuffle) x
|
||||
≡⟨ cong (λ φ → φ x)
|
||||
(cong (λ φ → φ ∘ idToIso* ∘ shuffle) (funExt (isoEq refl))) ⟩
|
||||
(shuffle~ ∘ ℂ.idToIso A B ∘ idToIso* ∘ shuffle) x
|
||||
≡⟨ cong (λ φ → φ x)
|
||||
(cong (λ φ → shuffle~ ∘ φ ∘ shuffle) recto-verso) ⟩
|
||||
(shuffle~ ∘ shuffle) x
|
||||
≡⟨⟩
|
||||
x ∎)
|
||||
)
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category}. Proving univalence for the opposite category.}
|
||||
\end{figure}
|
||||
\clearpage
|
||||
\section{Products}
|
||||
\label{sec:app-products}
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
open Category ℂ
|
||||
|
||||
module _ (A B : Object) where
|
||||
record RawProduct : Set (ℓa ⊔ ℓb) where
|
||||
no-eta-equality
|
||||
field
|
||||
object : Object
|
||||
fst : ℂ [ object , A ]
|
||||
snd : ℂ [ object , B ]
|
||||
|
||||
record IsProduct (raw : RawProduct) : Set (ℓa ⊔ ℓb) where
|
||||
open RawProduct raw public
|
||||
field
|
||||
ump : ∀ {X : Object} (f : ℂ [ X , A ]) (g : ℂ [ X , B ])
|
||||
→ ∃![ f×g ] (ℂ [ fst ∘ f×g ] ≡ f P.× ℂ [ snd ∘ f×g ] ≡ g)
|
||||
|
||||
record Product : Set (ℓa ⊔ ℓb) where
|
||||
field
|
||||
raw : RawProduct
|
||||
isProduct : IsProduct raw
|
||||
|
||||
open IsProduct isProduct public
|
||||
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category.Product}. Definition of products.}
|
||||
\end{figure}
|
||||
%
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module _{ℓa ℓb : Level} {ℂ : Category ℓa ℓb}
|
||||
(let module ℂ = Category ℂ) {A* B* : ℂ.Object} where
|
||||
|
||||
module _ where
|
||||
raw : RawCategory _ _
|
||||
raw = record
|
||||
{ Object = Σ[ X ∈ ℂ.Object ] ℂ.Arrow X A* × ℂ.Arrow X B*
|
||||
; Arrow = λ{ (A , a0 , a1) (B , b0 , b1)
|
||||
→ Σ[ f ∈ ℂ.Arrow A B ]
|
||||
ℂ [ b0 ∘ f ] ≡ a0
|
||||
× ℂ [ b1 ∘ f ] ≡ a1
|
||||
}
|
||||
; identity = λ{ {X , f , g}
|
||||
→ ℂ.identity {X} , ℂ.rightIdentity , ℂ.rightIdentity
|
||||
}
|
||||
; _<<<_ = λ { {_ , a0 , a1} {_ , b0 , b1} {_ , c0 , c1}
|
||||
(f , f0 , f1) (g , g0 , g1)
|
||||
→ (f ℂ.<<< g)
|
||||
, (begin
|
||||
ℂ [ c0 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
|
||||
ℂ [ ℂ [ c0 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f0 ⟩
|
||||
ℂ [ b0 ∘ g ] ≡⟨ g0 ⟩
|
||||
a0 ∎
|
||||
)
|
||||
, (begin
|
||||
ℂ [ c1 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
|
||||
ℂ [ ℂ [ c1 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f1 ⟩
|
||||
ℂ [ b1 ∘ g ] ≡⟨ g1 ⟩
|
||||
a1 ∎
|
||||
)
|
||||
}
|
||||
}
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category.Product}. Definition of ``pair category''.}
|
||||
\end{figure}
|
||||
\clearpage
|
||||
\section{Monads}
|
||||
\label{sec:app-monads}
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module Cat.Category.Monad.Kleisli
|
||||
{ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
|
||||
record RawMonad : Set ℓ where
|
||||
field
|
||||
omap : Object → Object
|
||||
pure : {X : Object} → ℂ [ X , omap X ]
|
||||
bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ]
|
||||
|
||||
fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ omap A , omap B ]
|
||||
fmap f = bind (pure <<< f)
|
||||
|
||||
_>=>_ : {A B C : Object}
|
||||
→ ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ]
|
||||
f >=> g = f >>> (bind g)
|
||||
|
||||
join : {A : Object} → ℂ [ omap (omap A) , omap A ]
|
||||
join = bind identity
|
||||
|
||||
IsIdentity = {X : Object}
|
||||
→ bind pure ≡ identity {omap X}
|
||||
IsNatural = {X Y : Object} (f : ℂ [ X , omap Y ])
|
||||
→ pure >=> f ≡ f
|
||||
IsDistributive = {X Y Z : Object}
|
||||
(g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ])
|
||||
→ (bind f) >>> (bind g) ≡ bind (f >=> g)
|
||||
|
||||
record IsMonad (raw : RawMonad) : Set ℓ where
|
||||
open RawMonad raw public
|
||||
field
|
||||
isIdentity : IsIdentity
|
||||
isNatural : IsNatural
|
||||
isDistributive : IsDistributive
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category.Monad.Kleisli}. Definition of
|
||||
Kleisli monads.}
|
||||
\end{figure}
|
||||
%
|
||||
\begin{figure}[h]
|
||||
\begin{Verbatim}
|
||||
module Cat.Category.Monad.Monoidal
|
||||
{ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
|
||||
private
|
||||
ℓ = ℓa ⊔ ℓb
|
||||
|
||||
open Category ℂ using (Object ; Arrow ; identity ; _<<<_)
|
||||
|
||||
record RawMonad : Set ℓ where
|
||||
field
|
||||
R : EndoFunctor ℂ
|
||||
pureNT : NaturalTransformation Functors.identity R
|
||||
joinNT : NaturalTransformation F[ R ∘ R ] R
|
||||
|
||||
Romap = Functor.omap R
|
||||
fmap = Functor.fmap R
|
||||
|
||||
pureT : Transformation Functors.identity R
|
||||
pureT = fst pureNT
|
||||
|
||||
pure : {X : Object} → ℂ [ X , Romap X ]
|
||||
pure = pureT _
|
||||
|
||||
pureN : Natural Functors.identity R pureT
|
||||
pureN = snd pureNT
|
||||
|
||||
joinT : Transformation F[ R ∘ R ] R
|
||||
joinT = fst joinNT
|
||||
join : {X : Object} → ℂ [ Romap (Romap X) , Romap X ]
|
||||
join = joinT _
|
||||
joinN : Natural F[ R ∘ R ] R joinT
|
||||
joinN = snd joinNT
|
||||
|
||||
bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ]
|
||||
bind {X} {Y} f = join <<< fmap f
|
||||
|
||||
IsAssociative : Set _
|
||||
IsAssociative = {X : Object}
|
||||
→ joinT X <<< fmap join ≡ join <<< join
|
||||
IsInverse : Set _
|
||||
IsInverse = {X : Object}
|
||||
→ join <<< pure ≡ identity {Romap X}
|
||||
× join <<< fmap pure ≡ identity {Romap X}
|
||||
|
||||
record IsMonad (raw : RawMonad) : Set ℓ where
|
||||
open RawMonad raw public
|
||||
field
|
||||
isAssociative : IsAssociative
|
||||
isInverse : IsInverse
|
||||
\end{Verbatim}
|
||||
\caption{Excerpt from module \texttt{Cat.Category.Monad.Monoidal}. Definition of
|
||||
Monoidal monads.}
|
||||
\end{figure}
|
||||
|
|
@ -0,0 +1,95 @@
|
|||
%% FRONTMATTER
|
||||
\frontmatter
|
||||
%% \newgeometry{top=3cm, bottom=3cm,left=2.25 cm, right=2.25cm}
|
||||
\begingroup
|
||||
\thispagestyle{empty}
|
||||
{\Huge\thetitle}\\[.5cm]
|
||||
{\Large A formalization of category theory in Cubical Agda}\\[6cm]
|
||||
\begin{center}
|
||||
\includegraphics[width=\linewidth,keepaspectratio]{isomorphism.png}
|
||||
\end{center}
|
||||
% Cover text
|
||||
\vfill
|
||||
%% \renewcommand{\familydefault}{\sfdefault} \normalfont % Set cover page font
|
||||
{\Large\theauthor}\\[.5cm]
|
||||
Master's thesis in Computer Science
|
||||
\endgroup
|
||||
%% \end{titlepage}
|
||||
|
||||
|
||||
% BACK OF COVER PAGE (BLANK PAGE)
|
||||
\newpage
|
||||
%% \newgeometry{a4paper} % Temporarily change margins
|
||||
%% \restoregeometry
|
||||
\thispagestyle{empty}
|
||||
\null
|
||||
|
||||
%% \begin{titlepage}
|
||||
|
||||
% TITLE PAGE
|
||||
\newpage
|
||||
\thispagestyle{empty}
|
||||
\begin{center}
|
||||
\textsc{\LARGE Master's thesis \the\year}\\[4cm] % Report number is currently not in use
|
||||
\textbf{\LARGE \thetitle} \\[1cm]
|
||||
{\large \subtitle}\\[1cm]
|
||||
{\large \theauthor}
|
||||
|
||||
\vfill
|
||||
\centering
|
||||
\includegraphics[width=0.2\pdfpagewidth]{assets/logo_eng.pdf}
|
||||
\vspace{5mm}
|
||||
|
||||
\textsc{Department of Computer Science and Engineering}\\
|
||||
\textsc{{\researchgroup}}\\
|
||||
%Name of research group (if applicable)\\
|
||||
\textsc{\institution} \\
|
||||
\textsc{Gothenburg, Sweden \the\year}\\
|
||||
\end{center}
|
||||
|
||||
|
||||
% IMPRINT PAGE (BACK OF TITLE PAGE)
|
||||
\newpage
|
||||
\thispagestyle{plain}
|
||||
\textit{\thetitle}\\
|
||||
\subtitle\\
|
||||
\copyright\ \the\year ~ \textsc{\theauthor}
|
||||
\vspace{4.5cm}
|
||||
|
||||
\setlength{\parskip}{0.5cm}
|
||||
\textbf{Author:}\\
|
||||
\theauthor\\
|
||||
\href{mailto:\authoremail>}{\texttt{<\authoremail>}}
|
||||
|
||||
\textbf{Supervisor:}\\
|
||||
\supervisor\\
|
||||
\href{mailto:\supervisoremail>}{\texttt{<\supervisoremail>}}\\
|
||||
\supervisordepartment
|
||||
|
||||
\textbf{Co-supervisor:}\\
|
||||
\cosupervisor\\
|
||||
\href{mailto:\cosupervisoremail>}{\texttt{<\cosupervisoremail>}}\\
|
||||
\cosupervisordepartment
|
||||
|
||||
\textbf{Examiner:}\\
|
||||
\examiner\\
|
||||
\href{mailto:\examineremail>}{\texttt{<\examineremail>}}\\
|
||||
\examinerdepartment
|
||||
|
||||
\vfill
|
||||
Master's Thesis \the\year\\ % Report number currently not in use
|
||||
\department\\
|
||||
%Division of Division name\\
|
||||
%Name of research group (if applicable)\\
|
||||
\institution\\
|
||||
SE-412 96 Gothenburg\\
|
||||
Telephone +46 31 772 1000 \setlength{\parskip}{0.5cm}\\
|
||||
% Caption for cover page figure if used, possibly with reference to further information in the report
|
||||
%% Cover: Wind visualization constructed in Matlab showing a surface of constant wind speed along with streamlines of the flow. \setlength{\parskip}{0.5cm}
|
||||
%Printed by [Name of printing company]\\
|
||||
Gothenburg, Sweden \the\year
|
||||
|
||||
%% \restoregeometry
|
||||
%% \end{titlepage}
|
||||
|
||||
\tableofcontents
|
||||
|
|
@ -1 +1 @@
|
|||
Subproject commit fbd8ba7ea84c4b643fd08797b4031b18a59f561d
|
||||
Subproject commit ac331fc38ca05f85dfebc57eb1259ba2ea0e50d5
|
||||
|
|
@ -1 +1 @@
|
|||
Subproject commit 5b35333dbbd8fa523e478c1cfe60657321ca38fe
|
||||
Subproject commit b112c292ded61b02fa32a1b65cac77314a1e9698
|
||||
|
|
@ -1,22 +0,0 @@
|
|||
Remove stuff about models of type theory
|
||||
|
||||
Add references to specific (noteable) implementaitons of category theory:
|
||||
* Unimath
|
||||
* cubicaltt
|
||||
* https://github.com/pcapriotti/agda-categories
|
||||
* https://github.com/copumpkin/categories
|
||||
* ...
|
||||
|
||||
Talk about structure of library:
|
||||
===
|
||||
|
||||
Propositional- and non-propositional stuff split up
|
||||
Providing "equiality principles"
|
||||
Provide overview of what has been proven.
|
||||
|
||||
What can I say about reusability?
|
||||
|
||||
Misc
|
||||
====
|
||||
|
||||
Propositional content
|
||||
|
|
@ -1,56 +0,0 @@
|
|||
% Requires: hypperref
|
||||
\ProvidesPackage{chalmerstitle}
|
||||
|
||||
\newcommand*{\authoremail}[1]{\gdef\@authoremail{#1}}
|
||||
\newcommand*{\supervisor}[1]{\gdef\@supervisor{#1}}
|
||||
\newcommand*{\supervisoremail}[1]{\gdef\@supervisoremail{#1}}
|
||||
\newcommand*{\cosupervisor}[1]{\gdef\@cosupervisor{#1}}
|
||||
\newcommand*{\cosupervisoremail}[1]{\gdef\@cosupervisoremail{#1}}
|
||||
\newcommand*{\institution}[1]{\gdef\@institution{#1}}
|
||||
|
||||
\renewcommand*{\maketitle}{%
|
||||
\begin{titlepage}
|
||||
|
||||
|
||||
\begin{center}
|
||||
|
||||
|
||||
{\scshape\LARGE Master thesis project proposal\\}
|
||||
|
||||
\vspace{0.5cm}
|
||||
|
||||
{\LARGE\bfseries \@title\\}
|
||||
|
||||
\vspace{2cm}
|
||||
|
||||
{\Large \@author\\ \href{mailto:\@authoremail>}{\texttt{<\@authoremail>}} \\}
|
||||
|
||||
% \vspace{0.2cm}
|
||||
%
|
||||
% {\Large name and email adress of student 2\\}
|
||||
|
||||
\vspace{1.0cm}
|
||||
|
||||
{\large Supervisor: \@supervisor\\ \href{mailto:\@supervisoremail>}{\texttt{<\@supervisoremail>}}\\}
|
||||
|
||||
\vspace{0.2cm}
|
||||
|
||||
{\large Co-supervisor: \@cosupervisor\\ \href{mailto:\@cosupervisoremail>}{\texttt{<\@cosupervisoremail>}}\\}
|
||||
|
||||
\vspace{1.5cm}
|
||||
|
||||
{\large Relevant completed courses:\par}
|
||||
{\itshape
|
||||
Logic in Computer Science -- DAT060\\
|
||||
Models of Computation -- TDA184\\
|
||||
Research topic in Computer Science -- DAT235\\
|
||||
Types for programs and proofs -- DAT140
|
||||
}
|
||||
|
||||
\vfill
|
||||
|
||||
{\large \@institution\\\today\\}
|
||||
|
||||
\end{center}
|
||||
\end{titlepage}
|
||||
}
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
\newcommand{\coloneqq}{\mathrel{\vcenter{\baselineskip0.5ex \lineskiplimit0pt
|
||||
\hbox{\scriptsize.}\hbox{\scriptsize.}}}%
|
||||
=}
|
||||
|
||||
\newcommand{\defeq}{\coloneqq}
|
||||
\newcommand{\bN}{\mathbb{N}}
|
||||
\newcommand{\bC}{\mathbb{C}}
|
||||
\newcommand{\bX}{\mathbb{X}}
|
||||
% \newcommand{\to}{\rightarrow}
|
||||
\newcommand{\mto}{\mapsto}
|
||||
\newcommand{\UU}{\ensuremath{\mathcal{U}}\xspace}
|
||||
\let\type\UU
|
||||
\newcommand{\nomen}[1]{\emph{#1}}
|
||||
\newcommand{\todo}[1]{\textit{#1}}
|
||||
\newcommand{\comp}{\circ}
|
||||
\newcommand{\x}{\times}
|
||||
\newcommand{\Hom}{\mathit{Hom}}
|
||||
\newcommand{\fmap}{\mathit{fmap}}
|
||||
\newcommand{\idFun}{\mathit{id}}
|
||||
\newcommand{\Sets}{\mathit{Sets}}
|
||||
\newcommand{\Set}{\mathit{Set}}
|
||||
\newcommand{\MCU}{\UU}
|
||||
\newcommand{\isSet}{\mathit{isSet}}
|
||||
\newcommand{\tp}{\;\mathord{:}\;}
|
||||
\newcommand{\subsubsubsection}[1]{\textbf{#1}}
|
||||
\newcommand{\WIP}[1]{\textbf{[WIP]}}
|
||||
|
|
@ -1,289 +0,0 @@
|
|||
\documentclass{article}
|
||||
|
||||
|
||||
|
||||
\usepackage[utf8]{inputenc}
|
||||
|
||||
\usepackage{natbib}
|
||||
\usepackage[hidelinks]{hyperref}
|
||||
|
||||
\usepackage{graphicx}
|
||||
|
||||
\usepackage{parskip}
|
||||
\usepackage{multicol}
|
||||
\usepackage{amsmath,amssymb}
|
||||
\usepackage[toc,page]{appendix}
|
||||
\usepackage{xspace}
|
||||
|
||||
% \setlength{\parskip}{10pt}
|
||||
|
||||
% \usepackage{tikz}
|
||||
% \usetikzlibrary{arrows, decorations.markings}
|
||||
|
||||
% \usepackage{chngcntr}
|
||||
% \counterwithout{figure}{section}
|
||||
|
||||
\usepackage{chalmerstitle}
|
||||
\input{macros.tex}
|
||||
|
||||
\title{Category Theory and Cubical Type Theory}
|
||||
\author{Frederik Hanghøj Iversen}
|
||||
\authoremail{hanghj@student.chalmers.se}
|
||||
\supervisor{Thierry Coquand}
|
||||
\supervisoremail{coquand@chalmers.se}
|
||||
\cosupervisor{Andrea Vezzosi}
|
||||
\cosupervisoremail{vezzosi@chalmers.se}
|
||||
\institution{Chalmers University of Technology}
|
||||
|
||||
\begin{document}
|
||||
|
||||
\maketitle
|
||||
%
|
||||
\section{Introduction}
|
||||
%
|
||||
Functional extensionality and univalence is not expressible in
|
||||
\nomen{Intensional Martin Löf Type Theory} (ITT). This poses a severe limitation
|
||||
on both 1) what is \emph{provable} and 2) the \emph{reusability} of proofs.
|
||||
Recent developments have, however, resulted in \nomen{Cubical Type Theory} (CTT)
|
||||
which permits a constructive proof of these two important notions.
|
||||
|
||||
Furthermore an extension has been implemented for the proof assistant Agda
|
||||
(\cite{agda}) that allows us to work in such a ``cubical setting''. This project
|
||||
will be concerned with exploring the usefulness of this extension. As a
|
||||
case-study I will consider \nomen{category theory}. This will serve a dual
|
||||
purpose: First off category theory is a field where the notion of functional
|
||||
extensionality and univalence wil be particularly useful. Secondly, Category
|
||||
Theory gives rise to a \nomen{model} for CTT.
|
||||
|
||||
The project will consist of two parts: The first part will be concerned with
|
||||
formalizing concepts from category theory. The focus will be on formalizing
|
||||
parts that will be useful in the second part of the project: Showing that
|
||||
\nomen{Cubical Sets} give rise to a model of CTT.
|
||||
%
|
||||
\section{Problem}
|
||||
%
|
||||
In the following two subsections I present two examples that illustrate the
|
||||
limitation inherent in ITT and by extension to the expressiveness of Agda.
|
||||
%
|
||||
\subsection{Functional extensionality}
|
||||
Consider the functions:
|
||||
%
|
||||
\begin{multicols}{2}
|
||||
$f \defeq (n : \bN) \mapsto (0 + n : \bN)$
|
||||
|
||||
$g \defeq (n : \bN) \mapsto (n + 0 : \bN)$
|
||||
\end{multicols}
|
||||
%
|
||||
$n + 0$ is definitionally equal to $n$. We call this \nomen{definitional
|
||||
equality} and write $n + 0 = n$ to assert this fact. We call it definitional
|
||||
equality because the \emph{equality} arises from the \emph{definition} of $+$
|
||||
which is:
|
||||
%
|
||||
\newcommand{\suc}[1]{\mathit{suc}\ #1}
|
||||
\begin{align*}
|
||||
+ & : \bN \to \bN \\
|
||||
n + 0 & \defeq n \\
|
||||
n + (\suc{m}) & \defeq \suc{(n + m)}
|
||||
\end{align*}
|
||||
%
|
||||
Note that $0 + n$ is \emph{not} definitionally equal to $n$. $0 + n$ is in
|
||||
normal form. I.e.; there is no rule for $+$ whose left-hand-side matches this
|
||||
expression. We \emph{do}, however, have that they are \nomen{propositionally}
|
||||
equal. We write $n + 0 \equiv n$ to assert this fact. Propositional equality
|
||||
means that there is a proof that exhibits this relation. Since equality is a
|
||||
transitive relation we have that $n + 0 \equiv 0 + n$.
|
||||
|
||||
Unfortunately we don't have $f \equiv g$.\footnote{Actually showing this is
|
||||
outside the scope of this text. Essentially it would involve giving a model
|
||||
for our type theory that validates all our axioms but where $f \equiv g$ is
|
||||
not true.} There is no way to construct a proof asserting the obvious
|
||||
equivalence of $f$ and $g$ -- even though we can prove them equal for all
|
||||
points. This is exactly the notion of equality of functions that we are
|
||||
interested in; that they are equal for all inputs. We call this
|
||||
\nomen{pointwise equality}, where the \emph{points} of a function refers
|
||||
to it's arguments.
|
||||
|
||||
In the context of category theory the principle of functional extensionality is
|
||||
for instance useful in the context of showing that representable functors are
|
||||
indeed functors. The representable functor for a category $\bC$ and a fixed
|
||||
object in $A \in \bC$ is defined to be:
|
||||
%
|
||||
\begin{align*}
|
||||
\fmap \defeq X \mapsto \Hom_{\bC}(A, X)
|
||||
\end{align*}
|
||||
%
|
||||
The proof obligation that this satisfies the identity law of functors
|
||||
($\fmap\ \idFun \equiv \idFun$) becomes:
|
||||
%
|
||||
\begin{align*}
|
||||
\Hom(A, \idFun_{\bX}) = (g \mapsto \idFun \comp g) \equiv \idFun_{\Sets}
|
||||
\end{align*}
|
||||
%
|
||||
One needs functional extensionality to ``go under'' the function arrow and apply
|
||||
the (left) identity law of the underlying category to proove $\idFun \comp g
|
||||
\equiv g$ and thus closing the above proof.
|
||||
%
|
||||
\iffalse
|
||||
I also want to talk about:
|
||||
\begin{itemize}
|
||||
\item
|
||||
Foundational systems
|
||||
\item
|
||||
Theory vs. metatheory
|
||||
\item
|
||||
Internal type theory
|
||||
\end{itemize}
|
||||
\fi
|
||||
\subsection{Equality of isomorphic types}
|
||||
%
|
||||
Let $\top$ denote the unit type -- a type with a single constructor. In the
|
||||
propositions-as-types interpretation of type theory $\top$ is the proposition
|
||||
that is always true. The type $A \x \top$ and $A$ has an element for each $a :
|
||||
A$. So in a sense they are the same. The second element of the pair does not add
|
||||
any ``interesting information''. It can be useful to identify such types. In
|
||||
fact, it is quite commonplace in mathematics. Say we look at a set $\{x \mid
|
||||
\phi\ x \land \psi\ x\}$ and somehow conclude that $\psi\ x \equiv \top$ for all
|
||||
$x$. A mathematician would immediately conclude $\{x \mid \phi\ x \land
|
||||
\psi\ x\} \equiv \{x \mid \phi\ x\}$ without thinking twice. Unfortunately such
|
||||
an identification can not be performed in ITT.
|
||||
|
||||
More specifically; what we are interested in is a way of identifying types that
|
||||
are in a one-to-one correspondence. We say that such types are
|
||||
\nomen{isomorphic} and write $A \cong B$ to assert this.
|
||||
|
||||
To prove two types isomorphic is to give an \nomen{isomorphism} between them.
|
||||
That is, a function $f : A \to B$ with an inverse $f^{-1} : B \to A$, i.e.:
|
||||
$f^{-1} \comp f \equiv id_A$. If such a function exist we say that $A$ and $B$
|
||||
are isomorphic and write $A \cong B$.
|
||||
|
||||
Furthermore we want to \emph{identify} such isomorphic types. This, we get from
|
||||
the principle of univalence:\footnote{It's often referred to as the univalence
|
||||
axiom, but since it is not an axiom in this setting but rather a theorem I
|
||||
refer to this just as a `principle'.}
|
||||
%
|
||||
$$(A \cong B) \cong (A \equiv B)$$
|
||||
%
|
||||
\subsection{Formalizing Category Theory}
|
||||
%
|
||||
The above examples serve to illustrate the limitation of Agda. One case where
|
||||
these limitations are particularly prohibitive is in the study of Category
|
||||
Theory. At a glance category theory can be described as ``the mathematical study
|
||||
of (abstract) algebras of functions'' (\cite{awodey-2006}). So by that token
|
||||
functional extensionality is particularly useful for formulating Category
|
||||
Theory. In Category theory it is also common to identify isomorphic structures
|
||||
and this is exactly what we get from univalence.
|
||||
|
||||
\subsection{Cubical model for Cubical Type Theory}
|
||||
%
|
||||
A model is a way of giving meaning to a formal system in a \emph{meta-theory}. A
|
||||
typical example of a model is that of sets as models for predicate logic. Thus
|
||||
set-theory becomes the meta-theory of the formal language of predicate logic.
|
||||
|
||||
In the context of a given type theory and restricting ourselves to
|
||||
\emph{categorical} models a model will consist of mapping `things' from the
|
||||
type-theory (types, terms, contexts, context morphisms) to `things' in the
|
||||
meta-theory (objects, morphisms) in such a way that the axioms of the
|
||||
type-theory (typing-rules) are validated in the meta-theory. In
|
||||
\cite{dybjer-1995} the author describes a way of constructing such models for
|
||||
dependent type theory called \emph{Categories with Families} (CwFs).
|
||||
|
||||
In \cite{bezem-2014} the authors devise a CwF for Cubical Type Theory. This
|
||||
project will study and formalize this model. Note that I will \emph{not} aim to
|
||||
formalize CTT itself and therefore also not give the formal translation between
|
||||
the type theory and the meta-theory. Instead the translation will be accounted
|
||||
for informally.
|
||||
|
||||
The project will formalize CwF's. It will also define what pieces of data are
|
||||
needed for a model of CTT (without explicitly showing that it does in fact model
|
||||
CTT). It will then show that a CwF gives rise to such a model. Furthermore I
|
||||
will show that cubical sets are presheaf categories and that any presheaf
|
||||
category is itself a CwF. This is the precise way by which the project aims to
|
||||
provide a model of CTT. Note that this formalization specifcally does not
|
||||
mention the language of CTT itself. Only be referencing this previous work do we
|
||||
arrive at a model of CTT.
|
||||
%
|
||||
\section{Context}
|
||||
%
|
||||
In \cite{bezem-2014} a categorical model for cubical type theory is presented.
|
||||
In \cite{cohen-2016} a type-theory where univalence is expressible is presented.
|
||||
The categorical model in the previous reference serve as a model of this type
|
||||
theory. So these two ideas are closely related. Cubical type theory arose out of
|
||||
\nomen{Homotopy Type Theory} (\cite{hott-2013}) and is also of interest as a
|
||||
foundation of mathematics (\cite{voevodsky-2011}).
|
||||
|
||||
An implementation of cubical type theory can be found as an extension to Agda.
|
||||
This is due to \citeauthor{cubical-agda}. This, of course, will be central to
|
||||
this thesis.
|
||||
|
||||
The idea of formalizing Category Theory in proof assistants is not a new
|
||||
idea\footnote{There are a multitude of these available online. Just as first
|
||||
reference see this question on Math Overflow: \cite{mo-formalizations}}. The
|
||||
contribution of this thesis is to explore how working in a cubical setting will
|
||||
make it possible to prove more things and to reuse proofs.
|
||||
|
||||
There are alternative approaches to working in a cubical setting where one can
|
||||
still have univalence and functional extensionality. One option is to postulate
|
||||
these as axioms. This approach, however, has other shortcomings, e.g.; you lose
|
||||
\nomen{canonicity} (\cite{huber-2016}). Canonicity means that any well-type
|
||||
term will (under evaluation) reduce to a \emph{canonical} form. For example for
|
||||
an integer $e : \bN$ it will be the case that $e$ is definitionally equal to $n$
|
||||
applications of $\mathit{suc}$ to $0$ for some $n$; $e = \mathit{suc}^n\ 0$.
|
||||
Without canonicity terms in the language can get ``stuck'' when they are
|
||||
evaluated.
|
||||
|
||||
Another approach is to use the \emph{setoid interpretation} of type theory
|
||||
(\cite{hofmann-1995,huber-2016}). Types should additionally `carry around' an
|
||||
equivalence relation that should serve as propositional equality. This approach
|
||||
has other drawbacks; it does not satisfy all judgemental equalites of type
|
||||
theory and is cumbersome to work with in practice (\cite[p. 4]{huber-2016}).
|
||||
%
|
||||
\section{Goals and Challenges}
|
||||
%
|
||||
In summary, the aim of the project is to:
|
||||
%
|
||||
\begin{itemize}
|
||||
\item
|
||||
Formalize Category Theory in Cubical Agda
|
||||
\item
|
||||
Formalize Cubical Sets in Agda
|
||||
% \item
|
||||
% Formalize Cubical Type Theory in Agda
|
||||
\item
|
||||
Show that Cubical Sets are a model for Cubical Type Theory
|
||||
\end{itemize}
|
||||
%
|
||||
The formalization of category theory will focus on extracting the elements from
|
||||
Category Theory that we need in the latter part of the project. In doing so I'll
|
||||
be gaining experience with working with Cubical Agda. Equality proofs using
|
||||
cubical Agda can be tricky, so working with that will be a challenge in itself.
|
||||
Most of the proofs in the context of cubical models I will formalize are based
|
||||
on previous work. Those proofs, however, are not formalized in a proof
|
||||
assistant.
|
||||
|
||||
One particular challenge in this context is that in a cubical setting there can
|
||||
be multiple distinct terms that inhabit a given equality proof.\footnote{This is
|
||||
in contrast with ITT where one \emph{can} have \nomen{Uniqueness of identity proofs}
|
||||
(\cite[p. 4]{huber-2016}).} This means that the choice for a given equality
|
||||
proof can influence later proofs that refer back to said proof. This is new and
|
||||
relatively unexplored territory.
|
||||
|
||||
Another challenge is that Category Theory is something that I only know the
|
||||
basics of. So learning the necessary concepts from Category Theory will also be
|
||||
a goal and a challenge in itself.
|
||||
|
||||
After this has been implemented it would also be possible to formalize Cubical
|
||||
Type Theory and formally show that Cubical Sets are a model of this. I do not
|
||||
intend to formally implement the language of dependent type theory in this
|
||||
project.
|
||||
|
||||
The thesis shall conclude with a discussion about the benefits of Cubical Agda.
|
||||
%
|
||||
\bibliographystyle{plainnat}
|
||||
\nocite{cubical-demo}
|
||||
\nocite{coquand-2013}
|
||||
\bibliography{refs}
|
||||
\begin{appendices}
|
||||
\input{planning.tex}
|
||||
\input{halftime.tex}
|
||||
\end{appendices}
|
||||
\end{document}
|
||||
|
|
@ -1 +0,0 @@
|
|||
cat.pdf
|
||||
|
|
@ -1,40 +0,0 @@
|
|||
PROJECT = cat
|
||||
PDF = $(PROJECT).pdf
|
||||
NOTES = $(PROJECT).md
|
||||
|
||||
preview: report
|
||||
xdg-open $(PDF)
|
||||
|
||||
report: $(PDF)
|
||||
|
||||
$(PDF): $(NOTES)
|
||||
pandoc $(NOTES) \
|
||||
-o $(PDF) \
|
||||
--latex-engine=xelatex \
|
||||
--variable urlcolor=cyan \
|
||||
-V papersize:a4 \
|
||||
-V geometry:margin=1.5in \
|
||||
--filter pandoc-citeproc
|
||||
|
||||
github: README.md
|
||||
|
||||
README.md: $(NOTES)
|
||||
pandoc $(NOTES) \
|
||||
-o README.md
|
||||
|
||||
run:
|
||||
stack exec lab4
|
||||
|
||||
build:
|
||||
stack build
|
||||
|
||||
dist: report
|
||||
tar \
|
||||
--transform "s/^/$(PROJECT)\//" \
|
||||
-zcvf $(PROJECT).tar.gz \
|
||||
$(SOURCE) \
|
||||
LICENSE \
|
||||
stack.yaml \
|
||||
lab4.cabal \
|
||||
Makefile \
|
||||
$(PDF)
|
||||
|
|
@ -1,90 +0,0 @@
|
|||
---
|
||||
title: Formalizing category theory in Agda - Project description
|
||||
date: May 27th 2017
|
||||
author: Frederik Hanghøj Iversen `<hanghj@student.chalmers.se>`
|
||||
bibliography: refs.bib
|
||||
---
|
||||
|
||||
Background
|
||||
==========
|
||||
|
||||
Functional extensionality gives rise to a notion of equality of functions not
|
||||
present in intensional dependent type theory. A type-system called cubical
|
||||
type-theory is outlined in [@cohen-2016] that recovers the computational
|
||||
interprtation of the univalence theorem.
|
||||
|
||||
Keywords: The category of sets, limits, colimits, functors, natural
|
||||
transformations, kleisly category, yoneda lemma, closed cartesian categories,
|
||||
propositional logic.
|
||||
|
||||
<!--
|
||||
"[...] These foundations promise to resolve several seemingly unconnected
|
||||
problems-provide a support for categorical and higher categorical arguments
|
||||
directly on the level of the language, make formalizations of usual mathematics
|
||||
much more concise and much better adapted to the use with existing proof
|
||||
assistants such as Coq [...]"
|
||||
|
||||
From "Univalent Foundations of Mathematics" by "Voevodsky".
|
||||
|
||||
-->
|
||||
|
||||
Aim
|
||||
===
|
||||
|
||||
The aim of the project is two-fold. The first part of the project will be
|
||||
concerned with formalizing some concepts from category theory in Agda's
|
||||
type-system. This formalization should aim to incorporate definitions and
|
||||
theorems that allow us to express the correpondence in the second part: Namely
|
||||
showing the correpondence between well-typed terms in cubical type theory as
|
||||
presented in Huber and Thierry's paper and with that of some concepts from Category Theory.
|
||||
|
||||
This latter part is not entirely clear for me yet, I know that all these are relevant keywords:
|
||||
|
||||
* The category, C, of names and substitutions
|
||||
* Cubical Sets, i.e.: Functors from C to Set (the category of sets)
|
||||
* Presheaves
|
||||
* Fibers and fibrations
|
||||
|
||||
These are all formulated in the language of Category Theory. The purpose it to
|
||||
show what they correspond to in the in Cubical Type Theory. As I understand it
|
||||
at least the last buzzword on this list corresponds to Type Families.
|
||||
|
||||
I'm not sure how I'll go about expressing this in Agda. I suspect it might
|
||||
be a matter of demostrating that these two formulations are isomorphic.
|
||||
|
||||
So far I have some experience with at least expressing some categorical
|
||||
concepts in Agda using this new notion of equality. That is, equaility is in
|
||||
some sense a continuuous path from a point of some type to another. So at the
|
||||
moment, my understanding of cubical type theory is just that it has another
|
||||
notion of equality but is otherwise pretty much the same.
|
||||
|
||||
Timeplan
|
||||
========
|
||||
|
||||
The first part of the project will focus on studying and understanding the
|
||||
foundations for this project namely; familiarizing myself with basic concepts
|
||||
from category theory, understanding how cubical type theory gives rise to
|
||||
expressing functional extensionality and the univalence theorem.
|
||||
|
||||
After I have understood these fundamental concepts I will use them in the
|
||||
formalization of functors, applicative functors, monads, etc.. in Agda. This
|
||||
should be done before the end of the first semester of the school-year
|
||||
2017/2018.
|
||||
|
||||
At this point I will also have settled on a direction for the rest of the
|
||||
project and developed a time-plan for the second phase of the project. But
|
||||
cerainly it will involve applying the result of phase 1 in some context as
|
||||
mentioned in [the project aim][aim].
|
||||
|
||||
Resources
|
||||
=========
|
||||
|
||||
* Cubical demo by Andrea Vezossi: [@cubical-demo]
|
||||
* Paper on cubical type theory [@cohen-2016]
|
||||
* Book on homotopy type theory: [@hott-2013]
|
||||
* Book on category theory: [@awodey-2006]
|
||||
* Modal logic - Modal type theory,
|
||||
see [ncatlab](https://ncatlab.org/nlab/show/modal+type+theory).
|
||||
|
||||
References
|
||||
==========
|
||||
|
|
@ -1,42 +0,0 @@
|
|||
@article{cohen-2016,
|
||||
author = {Cyril Cohen and
|
||||
Thierry Coquand and
|
||||
Simon Huber and
|
||||
Anders M{\"{o}}rtberg},
|
||||
title =
|
||||
{ Cubical Type Theory:
|
||||
a constructive interpretation of the univalence axiom
|
||||
},
|
||||
journal = {CoRR},
|
||||
volume = {abs/1611.02108},
|
||||
year = {2016},
|
||||
url = {http://arxiv.org/abs/1611.02108},
|
||||
timestamp = {Thu, 01 Dec 2016 19:32:08 +0100},
|
||||
biburl = {http://dblp.uni-trier.de/rec/bib/journals/corr/CohenCHM16},
|
||||
bibsource = {dblp computer science bibliography, http://dblp.org}
|
||||
}
|
||||
@book{hott-2013,
|
||||
author = {The {Univalent Foundations Program}},
|
||||
title = {Homotopy Type Theory: Univalent Foundations of Mathematics},
|
||||
publisher = {\url{https://homotopytypetheory.org/book}},
|
||||
address = {Institute for Advanced Study},
|
||||
year = 2013
|
||||
}
|
||||
@book{awodey-2006,
|
||||
title={Category Theory},
|
||||
author={Awodey, S.},
|
||||
isbn={9780191513824},
|
||||
series={Oxford Logic Guides},
|
||||
url={https://books.google.se/books?id=IK\_sIDI2TCwC},
|
||||
year={2006},
|
||||
publisher={Ebsco Publishing}
|
||||
}
|
||||
@misc{cubical-demo,
|
||||
author = {Andrea Vezzosi},
|
||||
title = {Cubical Type Theory Demo},
|
||||
year = {2017},
|
||||
publisher = {GitHub},
|
||||
journal = {GitHub repository},
|
||||
howpublished = {\url{https://github.com/Saizan/cubical-demo}},
|
||||
commit = {a51d5654c439111110d5b6df3605b0043b10b753}
|
||||
}
|
||||
|
|
@ -10,14 +10,15 @@ open import Cat.Category.NaturalTransformation
|
|||
open import Cat.Category.Yoneda
|
||||
open import Cat.Category.Monoid
|
||||
open import Cat.Category.Monad
|
||||
open Cat.Category.Monad.Monoidal
|
||||
open Cat.Category.Monad.Kleisli
|
||||
open import Cat.Category.Monad.Monoidal
|
||||
open import Cat.Category.Monad.Kleisli
|
||||
open import Cat.Category.Monad.Voevodsky
|
||||
|
||||
open import Cat.Categories.Opposite
|
||||
open import Cat.Categories.Sets
|
||||
open import Cat.Categories.Cat
|
||||
open import Cat.Categories.Rel
|
||||
open import Cat.Categories.Free
|
||||
open import Cat.Categories.Fun
|
||||
open import Cat.Categories.Cube
|
||||
-- open import Cat.Categories.Cube
|
||||
open import Cat.Categories.CwF
|
||||
|
|
|
|||
|
|
@ -3,42 +3,22 @@
|
|||
|
||||
module Cat.Categories.Cat where
|
||||
|
||||
open import Cat.Prelude renaming (proj₁ to fst ; proj₂ to snd)
|
||||
open import Cat.Prelude renaming (fst to fst ; snd to snd)
|
||||
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor
|
||||
open import Cat.Category.Product
|
||||
open import Cat.Category.Exponential hiding (_×_ ; product)
|
||||
open import Cat.Category.NaturalTransformation
|
||||
import Cat.Category.NaturalTransformation
|
||||
open import Cat.Categories.Fun
|
||||
|
||||
-- The category of categories
|
||||
module _ (ℓ ℓ' : Level) where
|
||||
private
|
||||
module _ {𝔸 𝔹 ℂ 𝔻 : Category ℓ ℓ'} {F : Functor 𝔸 𝔹} {G : Functor 𝔹 ℂ} {H : Functor ℂ 𝔻} where
|
||||
assc : F[ H ∘ F[ G ∘ F ] ] ≡ F[ F[ H ∘ G ] ∘ F ]
|
||||
assc = Functor≡ refl
|
||||
|
||||
module _ {ℂ 𝔻 : Category ℓ ℓ'} {F : Functor ℂ 𝔻} where
|
||||
ident-r : F[ F ∘ identity ] ≡ F
|
||||
ident-r = Functor≡ refl
|
||||
|
||||
ident-l : F[ identity ∘ F ] ≡ F
|
||||
ident-l = Functor≡ refl
|
||||
|
||||
RawCat : RawCategory (lsuc (ℓ ⊔ ℓ')) (ℓ ⊔ ℓ')
|
||||
RawCategory.Object RawCat = Category ℓ ℓ'
|
||||
RawCategory.Arrow RawCat = Functor
|
||||
RawCategory.𝟙 RawCat = identity
|
||||
RawCategory._∘_ RawCat = F[_∘_]
|
||||
|
||||
private
|
||||
open RawCategory RawCat
|
||||
isAssociative : IsAssociative
|
||||
isAssociative {f = F} {G} {H} = assc {F = F} {G = G} {H = H}
|
||||
|
||||
isIdentity : IsIdentity identity
|
||||
isIdentity = ident-l , ident-r
|
||||
RawCategory.Object RawCat = Category ℓ ℓ'
|
||||
RawCategory.Arrow RawCat = Functor
|
||||
RawCategory.identity RawCat = Functors.identity
|
||||
RawCategory._<<<_ RawCat = F[_∘_]
|
||||
|
||||
-- NB! `ArrowsAreSets RawCat` is *not* provable. The type of functors,
|
||||
-- however, form a groupoid! Therefore there is no (1-)category of
|
||||
|
|
@ -68,51 +48,55 @@ module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where
|
|||
Obj = ℂ.Object × 𝔻.Object
|
||||
Arr : Obj → Obj → Set ℓ'
|
||||
Arr (c , d) (c' , d') = ℂ [ c , c' ] × 𝔻 [ d , d' ]
|
||||
𝟙 : {o : Obj} → Arr o o
|
||||
𝟙 = ℂ.𝟙 , 𝔻.𝟙
|
||||
_∘_ :
|
||||
identity : {o : Obj} → Arr o o
|
||||
identity = ℂ.identity , 𝔻.identity
|
||||
_<<<_ :
|
||||
{a b c : Obj} →
|
||||
Arr b c →
|
||||
Arr a b →
|
||||
Arr a c
|
||||
_∘_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) → ℂ [ bc∈C ∘ ab∈C ] , 𝔻 [ bc∈D ∘ ab∈D ]}
|
||||
_<<<_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) → ℂ [ bc∈C ∘ ab∈C ] , 𝔻 [ bc∈D ∘ ab∈D ]}
|
||||
|
||||
rawProduct : RawCategory ℓ ℓ'
|
||||
RawCategory.Object rawProduct = Obj
|
||||
RawCategory.Arrow rawProduct = Arr
|
||||
RawCategory.𝟙 rawProduct = 𝟙
|
||||
RawCategory._∘_ rawProduct = _∘_
|
||||
RawCategory.Object rawProduct = Obj
|
||||
RawCategory.Arrow rawProduct = Arr
|
||||
RawCategory.identity rawProduct = identity
|
||||
RawCategory._<<<_ rawProduct = _<<<_
|
||||
|
||||
open RawCategory rawProduct
|
||||
|
||||
arrowsAreSets : ArrowsAreSets
|
||||
arrowsAreSets = setSig {sA = ℂ.arrowsAreSets} {sB = λ x → 𝔻.arrowsAreSets}
|
||||
isIdentity : IsIdentity 𝟙
|
||||
isIdentity : IsIdentity identity
|
||||
isIdentity
|
||||
= Σ≡ (fst ℂ.isIdentity) (fst 𝔻.isIdentity)
|
||||
, Σ≡ (snd ℂ.isIdentity) (snd 𝔻.isIdentity)
|
||||
|
||||
isPreCategory : IsPreCategory rawProduct
|
||||
IsPreCategory.isAssociative isPreCategory = Σ≡ ℂ.isAssociative 𝔻.isAssociative
|
||||
IsPreCategory.isIdentity isPreCategory = isIdentity
|
||||
IsPreCategory.arrowsAreSets isPreCategory = arrowsAreSets
|
||||
|
||||
postulate univalent : Univalence.Univalent isIdentity
|
||||
instance
|
||||
isCategory : IsCategory rawProduct
|
||||
IsCategory.isAssociative isCategory = Σ≡ ℂ.isAssociative 𝔻.isAssociative
|
||||
IsCategory.isIdentity isCategory = isIdentity
|
||||
IsCategory.arrowsAreSets isCategory = arrowsAreSets
|
||||
IsCategory.univalent isCategory = univalent
|
||||
|
||||
isCategory : IsCategory rawProduct
|
||||
IsCategory.isPreCategory isCategory = isPreCategory
|
||||
IsCategory.univalent isCategory = univalent
|
||||
|
||||
object : Category ℓ ℓ'
|
||||
Category.raw object = rawProduct
|
||||
Category.isCategory object = isCategory
|
||||
|
||||
proj₁ : Functor object ℂ
|
||||
proj₁ = record
|
||||
fstF : Functor object ℂ
|
||||
fstF = record
|
||||
{ raw = record
|
||||
{ omap = fst ; fmap = fst }
|
||||
; isFunctor = record
|
||||
{ isIdentity = refl ; isDistributive = refl }
|
||||
}
|
||||
|
||||
proj₂ : Functor object 𝔻
|
||||
proj₂ = record
|
||||
sndF : Functor object 𝔻
|
||||
sndF = record
|
||||
{ raw = record
|
||||
{ omap = snd ; fmap = snd }
|
||||
; isFunctor = record
|
||||
|
|
@ -136,17 +120,27 @@ module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where
|
|||
open module x₁ = Functor x₁
|
||||
open module x₂ = Functor x₂
|
||||
|
||||
isUniqL : F[ proj₁ ∘ x ] ≡ x₁
|
||||
isUniqL : F[ fstF ∘ x ] ≡ x₁
|
||||
isUniqL = Functor≡ refl
|
||||
|
||||
isUniqR : F[ proj₂ ∘ x ] ≡ x₂
|
||||
isUniqR : F[ sndF ∘ x ] ≡ x₂
|
||||
isUniqR = Functor≡ refl
|
||||
|
||||
isUniq : F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂
|
||||
isUniq : F[ fstF ∘ x ] ≡ x₁ × F[ sndF ∘ x ] ≡ x₂
|
||||
isUniq = isUniqL , isUniqR
|
||||
|
||||
isProduct : ∃![ x ] (F[ proj₁ ∘ x ] ≡ x₁ × F[ proj₂ ∘ x ] ≡ x₂)
|
||||
isProduct = x , isUniq
|
||||
isProduct : ∃![ x ] (F[ fstF ∘ x ] ≡ x₁ × F[ sndF ∘ x ] ≡ x₂)
|
||||
isProduct = x , isUniq , uq
|
||||
where
|
||||
module _ {y : Functor X object} (eq : F[ fstF ∘ y ] ≡ x₁ × F[ sndF ∘ y ] ≡ x₂) where
|
||||
omapEq : Functor.omap x ≡ Functor.omap y
|
||||
omapEq = {!!}
|
||||
-- fmapEq : (λ i → {!{A B : ?} → Arrow A B → 𝔻 [ ? A , ? B ]!}) [ Functor.fmap x ≡ Functor.fmap y ]
|
||||
-- fmapEq = {!!}
|
||||
rawEq : Functor.raw x ≡ Functor.raw y
|
||||
rawEq = {!!}
|
||||
uq : x ≡ y
|
||||
uq = Functor≡ rawEq
|
||||
|
||||
module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where
|
||||
private
|
||||
|
|
@ -158,8 +152,8 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where
|
|||
|
||||
rawProduct : RawProduct Catℓ ℂ 𝔻
|
||||
RawProduct.object rawProduct = P.object
|
||||
RawProduct.proj₁ rawProduct = P.proj₁
|
||||
RawProduct.proj₂ rawProduct = P.proj₂
|
||||
RawProduct.fst rawProduct = P.fstF
|
||||
RawProduct.snd rawProduct = P.sndF
|
||||
|
||||
isProduct : IsProduct Catℓ _ _ rawProduct
|
||||
IsProduct.ump isProduct = P.isProduct
|
||||
|
|
@ -175,6 +169,9 @@ module _ {ℓ ℓ' : Level} (unprovable : IsCategory (RawCat ℓ ℓ')) where
|
|||
-- | The category of categories have expoentntials - and because it has products
|
||||
-- it is therefory also cartesian closed.
|
||||
module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where
|
||||
open Cat.Category.NaturalTransformation ℂ 𝔻
|
||||
renaming (identity to identityNT)
|
||||
using ()
|
||||
private
|
||||
module ℂ = Category ℂ
|
||||
module 𝔻 = Category 𝔻
|
||||
|
|
@ -189,8 +186,8 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where
|
|||
object = Fun
|
||||
|
||||
module _ {dom cod : Functor ℂ 𝔻 × ℂ.Object} where
|
||||
open Σ dom renaming (proj₁ to F ; proj₂ to A)
|
||||
open Σ cod renaming (proj₁ to G ; proj₂ to B)
|
||||
open Σ dom renaming (fst to F ; snd to A)
|
||||
open Σ cod renaming (fst to G ; snd to B)
|
||||
private
|
||||
module F = Functor F
|
||||
module G = Functor G
|
||||
|
|
@ -207,23 +204,23 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where
|
|||
open CatProduct renaming (object to _⊗_) using ()
|
||||
|
||||
module _ {c : Functor ℂ 𝔻 × ℂ.Object} where
|
||||
open Σ c renaming (proj₁ to F ; proj₂ to C)
|
||||
open Σ c renaming (fst to F ; snd to C)
|
||||
|
||||
ident : fmap {c} {c} (NT.identity F , ℂ.𝟙 {A = snd c}) ≡ 𝔻.𝟙
|
||||
ident : fmap {c} {c} (identityNT F , ℂ.identity {A = snd c}) ≡ 𝔻.identity
|
||||
ident = begin
|
||||
fmap {c} {c} (Category.𝟙 (object ⊗ ℂ) {c}) ≡⟨⟩
|
||||
fmap {c} {c} (idN F , ℂ.𝟙) ≡⟨⟩
|
||||
𝔻 [ identityTrans F C ∘ F.fmap ℂ.𝟙 ] ≡⟨⟩
|
||||
𝔻 [ 𝔻.𝟙 ∘ F.fmap ℂ.𝟙 ] ≡⟨ 𝔻.leftIdentity ⟩
|
||||
F.fmap ℂ.𝟙 ≡⟨ F.isIdentity ⟩
|
||||
𝔻.𝟙 ∎
|
||||
fmap {c} {c} (Category.identity (object ⊗ ℂ) {c}) ≡⟨⟩
|
||||
fmap {c} {c} (idN F , ℂ.identity) ≡⟨⟩
|
||||
𝔻 [ identityTrans F C ∘ F.fmap ℂ.identity ] ≡⟨⟩
|
||||
𝔻 [ 𝔻.identity ∘ F.fmap ℂ.identity ] ≡⟨ 𝔻.leftIdentity ⟩
|
||||
F.fmap ℂ.identity ≡⟨ F.isIdentity ⟩
|
||||
𝔻.identity ∎
|
||||
where
|
||||
module F = Functor F
|
||||
|
||||
module _ {F×A G×B H×C : Functor ℂ 𝔻 × ℂ.Object} where
|
||||
open Σ F×A renaming (proj₁ to F ; proj₂ to A)
|
||||
open Σ G×B renaming (proj₁ to G ; proj₂ to B)
|
||||
open Σ H×C renaming (proj₁ to H ; proj₂ to C)
|
||||
open Σ F×A renaming (fst to F ; snd to A)
|
||||
open Σ G×B renaming (fst to G ; snd to B)
|
||||
open Σ H×C renaming (fst to H ; snd to C)
|
||||
private
|
||||
module F = Functor F
|
||||
module G = Functor G
|
||||
|
|
@ -232,14 +229,14 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where
|
|||
module _
|
||||
{θ×f : NaturalTransformation F G × ℂ [ A , B ]}
|
||||
{η×g : NaturalTransformation G H × ℂ [ B , C ]} where
|
||||
open Σ θ×f renaming (proj₁ to θNT ; proj₂ to f)
|
||||
open Σ θNT renaming (proj₁ to θ ; proj₂ to θNat)
|
||||
open Σ η×g renaming (proj₁ to ηNT ; proj₂ to g)
|
||||
open Σ ηNT renaming (proj₁ to η ; proj₂ to ηNat)
|
||||
open Σ θ×f renaming (fst to θNT ; snd to f)
|
||||
open Σ θNT renaming (fst to θ ; snd to θNat)
|
||||
open Σ η×g renaming (fst to ηNT ; snd to g)
|
||||
open Σ ηNT renaming (fst to η ; snd to ηNat)
|
||||
private
|
||||
ηθNT : NaturalTransformation F H
|
||||
ηθNT = NT[_∘_] {F} {G} {H} ηNT θNT
|
||||
open Σ ηθNT renaming (proj₁ to ηθ ; proj₂ to ηθNat)
|
||||
open Σ ηθNT renaming (fst to ηθ ; snd to ηθNat)
|
||||
|
||||
isDistributive :
|
||||
𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ F.fmap ( ℂ [ g ∘ f ] ) ]
|
||||
|
|
@ -283,18 +280,18 @@ module CatExponential {ℓ : Level} (ℂ 𝔻 : Category ℓ ℓ) where
|
|||
: Functor 𝔸 object → Functor ℂ ℂ
|
||||
→ Functor (𝔸 ⊗ ℂ) (object ⊗ ℂ)
|
||||
transpose : Functor 𝔸 object
|
||||
eq : F[ eval ∘ (parallelProduct transpose (identity {C = ℂ})) ] ≡ F
|
||||
eq : F[ eval ∘ (parallelProduct transpose (Functors.identity {ℂ = ℂ})) ] ≡ F
|
||||
-- eq : F[ :eval: ∘ {!!} ] ≡ F
|
||||
-- eq : Catℓ [ :eval: ∘ (HasProducts._|×|_ hasProducts transpose (𝟙 Catℓ {o = ℂ})) ] ≡ F
|
||||
-- eq : Catℓ [ :eval: ∘ (HasProducts._|×|_ hasProducts transpose (identity Catℓ {o = ℂ})) ] ≡ F
|
||||
-- eq' : (Catℓ [ :eval: ∘
|
||||
-- (record { product = product } HasProducts.|×| transpose)
|
||||
-- (𝟙 Catℓ)
|
||||
-- (identity Catℓ)
|
||||
-- ])
|
||||
-- ≡ F
|
||||
|
||||
-- For some reason after `e8215b2c051062c6301abc9b3f6ec67106259758`
|
||||
-- `catTranspose` makes Agda hang. catTranspose : ∃![ F~ ] (Catℓ [
|
||||
-- :eval: ∘ (parallelProduct F~ (𝟙 Catℓ {o = ℂ}))] ≡ F) catTranspose =
|
||||
-- :eval: ∘ (parallelProduct F~ (identity Catℓ {o = ℂ}))] ≡ F) catTranspose =
|
||||
-- transpose , eq
|
||||
|
||||
-- We don't care about filling out the holes below since they are anyways hidden
|
||||
|
|
@ -318,8 +315,8 @@ module _ (ℓ : Level) (unprovable : IsCategory (RawCat ℓ ℓ)) where
|
|||
exponent : Exponential Catℓ ℂ 𝔻
|
||||
exponent = record
|
||||
{ obj = CatExp.object
|
||||
; eval = eval
|
||||
; isExponential = isExponential
|
||||
; eval = {!eval!}
|
||||
; isExponential = {!isExponential!}
|
||||
}
|
||||
|
||||
hasExponentials : HasExponentials Catℓ
|
||||
|
|
|
|||
|
|
@ -7,7 +7,6 @@ open import Data.Bool hiding (T)
|
|||
open import Data.Sum hiding ([_,_])
|
||||
open import Data.Unit
|
||||
open import Data.Empty
|
||||
open import Function
|
||||
open import Relation.Nullary
|
||||
open import Relation.Nullary.Decidable
|
||||
|
||||
|
|
@ -19,7 +18,7 @@ open import Cat.Category.Functor
|
|||
-- See section 6.8 in Huber's thesis for details on how to implement the
|
||||
-- categorical version of CTT
|
||||
|
||||
open Category hiding (_∘_)
|
||||
open Category hiding (_<<<_)
|
||||
open Functor
|
||||
|
||||
module _ {ℓ ℓ' : Level} (Ns : Set ℓ) where
|
||||
|
|
@ -55,9 +54,9 @@ module _ {ℓ ℓ' : Level} (Ns : Set ℓ) where
|
|||
→ case (f i) of λ
|
||||
{ (inj₁ (fi , _)) → case (f j) of λ
|
||||
{ (inj₁ (fj , _)) → fi ≡ fj → i ≡ j
|
||||
; (inj₂ _) → Lift ⊤
|
||||
; (inj₂ _) → Lift _ ⊤
|
||||
}
|
||||
; (inj₂ _) → Lift ⊤
|
||||
; (inj₂ _) → Lift _ ⊤
|
||||
}
|
||||
|
||||
Hom = Σ Hom' rules
|
||||
|
|
@ -67,8 +66,8 @@ module _ {ℓ ℓ' : Level} (Ns : Set ℓ) where
|
|||
Rawℂ : RawCategory ℓ ℓ -- ℓo (lsuc lzero ⊔ ℓo)
|
||||
Raw.Object Rawℂ = FiniteDecidableSubset
|
||||
Raw.Arrow Rawℂ = Hom
|
||||
Raw.𝟙 Rawℂ {o} = inj₁ , λ { (i , ii) (j , jj) eq → Σ≡ eq {!refl!} }
|
||||
Raw._∘_ Rawℂ = {!!}
|
||||
Raw.identity Rawℂ {o} = inj₁ , λ { (i , ii) (j , jj) eq → Σ≡ eq {!refl!} }
|
||||
Raw._<<<_ Rawℂ = {!!}
|
||||
|
||||
postulate IsCategoryℂ : IsCategory Rawℂ
|
||||
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@ open import Cat.Prelude
|
|||
open import Cat.Category
|
||||
open import Cat.Category.Functor
|
||||
open import Cat.Categories.Fam
|
||||
open import Cat.Categories.Opposite
|
||||
|
||||
module _ {ℓa ℓb : Level} where
|
||||
record CwF : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
|
|
@ -25,21 +26,21 @@ module _ {ℓa ℓb : Level} where
|
|||
private
|
||||
module T = Functor T
|
||||
Type : (Γ : ℂ.Object) → Set ℓa
|
||||
Type Γ = proj₁ (proj₁ (T.omap Γ))
|
||||
Type Γ = fst (fst (T.omap Γ))
|
||||
|
||||
module _ {Γ : ℂ.Object} {A : Type Γ} where
|
||||
|
||||
-- module _ {A B : Object ℂ} {γ : ℂ [ A , B ]} where
|
||||
-- k : Σ (proj₁ (omap T B) → proj₁ (omap T A))
|
||||
-- k : Σ (fst (omap T B) → fst (omap T A))
|
||||
-- (λ f →
|
||||
-- {x : proj₁ (omap T B)} →
|
||||
-- proj₂ (omap T B) x → proj₂ (omap T A) (f x))
|
||||
-- {x : fst (omap T B)} →
|
||||
-- snd (omap T B) x → snd (omap T A) (f x))
|
||||
-- k = T.fmap γ
|
||||
-- k₁ : proj₁ (omap T B) → proj₁ (omap T A)
|
||||
-- k₁ = proj₁ k
|
||||
-- k₂ : ({x : proj₁ (omap T B)} →
|
||||
-- proj₂ (omap T B) x → proj₂ (omap T A) (k₁ x))
|
||||
-- k₂ = proj₂ k
|
||||
-- k₁ : fst (omap T B) → fst (omap T A)
|
||||
-- k₁ = fst k
|
||||
-- k₂ : ({x : fst (omap T B)} →
|
||||
-- snd (omap T B) x → snd (omap T A) (k₁ x))
|
||||
-- k₂ = snd k
|
||||
|
||||
record ContextComprehension : Set (ℓa ⊔ ℓb) where
|
||||
field
|
||||
|
|
|
|||
|
|
@ -2,62 +2,60 @@
|
|||
module Cat.Categories.Fam where
|
||||
|
||||
open import Cat.Prelude
|
||||
import Function
|
||||
|
||||
open import Cat.Category
|
||||
|
||||
module _ (ℓa ℓb : Level) where
|
||||
private
|
||||
Object = Σ[ hA ∈ hSet ℓa ] (proj₁ hA → hSet ℓb)
|
||||
Object = Σ[ hA ∈ hSet ℓa ] (fst hA → hSet ℓb)
|
||||
Arr : Object → Object → Set (ℓa ⊔ ℓb)
|
||||
Arr ((A , _) , B) ((A' , _) , B') = Σ[ f ∈ (A → A') ] ({x : A} → proj₁ (B x) → proj₁ (B' (f x)))
|
||||
𝟙 : {A : Object} → Arr A A
|
||||
proj₁ 𝟙 = λ x → x
|
||||
proj₂ 𝟙 = λ b → b
|
||||
_∘_ : {a b c : Object} → Arr b c → Arr a b → Arr a c
|
||||
(g , g') ∘ (f , f') = g Function.∘ f , g' Function.∘ f'
|
||||
Arr ((A , _) , B) ((A' , _) , B') = Σ[ f ∈ (A → A') ] ({x : A} → fst (B x) → fst (B' (f x)))
|
||||
identity : {A : Object} → Arr A A
|
||||
fst identity = λ x → x
|
||||
snd identity = λ b → b
|
||||
_<<<_ : {a b c : Object} → Arr b c → Arr a b → Arr a c
|
||||
(g , g') <<< (f , f') = g ∘ f , g' ∘ f'
|
||||
|
||||
RawFam : RawCategory (lsuc (ℓa ⊔ ℓb)) (ℓa ⊔ ℓb)
|
||||
RawFam = record
|
||||
{ Object = Object
|
||||
; Arrow = Arr
|
||||
; 𝟙 = λ { {A} → 𝟙 {A = A}}
|
||||
; _∘_ = λ {a b c} → _∘_ {a} {b} {c}
|
||||
; identity = λ { {A} → identity {A = A}}
|
||||
; _<<<_ = λ {a b c} → _<<<_ {a} {b} {c}
|
||||
}
|
||||
|
||||
open RawCategory RawFam hiding (Object ; 𝟙)
|
||||
open RawCategory RawFam hiding (Object ; identity)
|
||||
|
||||
isAssociative : IsAssociative
|
||||
isAssociative = Σ≡ refl refl
|
||||
|
||||
isIdentity : IsIdentity λ { {A} → 𝟙 {A} }
|
||||
isIdentity : IsIdentity λ { {A} → identity {A} }
|
||||
isIdentity = (Σ≡ refl refl) , Σ≡ refl refl
|
||||
|
||||
open import Cubical.NType.Properties
|
||||
open import Cubical.Sigma
|
||||
instance
|
||||
isCategory : IsCategory RawFam
|
||||
isCategory = record
|
||||
{ isAssociative = λ {A} {B} {C} {D} {f} {g} {h} → isAssociative {A} {B} {C} {D} {f} {g} {h}
|
||||
; isIdentity = λ {A} {B} {f} → isIdentity {A} {B} {f = f}
|
||||
; arrowsAreSets = λ {
|
||||
{((A , hA) , famA)}
|
||||
{((B , hB) , famB)}
|
||||
→ setSig
|
||||
{sA = setPi λ _ → hB}
|
||||
{sB = λ f →
|
||||
let
|
||||
helpr : isSet ((a : A) → proj₁ (famA a) → proj₁ (famB (f a)))
|
||||
helpr = setPi λ a → setPi λ _ → proj₂ (famB (f a))
|
||||
-- It's almost like above, but where the first argument is
|
||||
-- implicit.
|
||||
res : isSet ({a : A} → proj₁ (famA a) → proj₁ (famB (f a)))
|
||||
res = {!!}
|
||||
in res
|
||||
}
|
||||
}
|
||||
; univalent = {!!}
|
||||
isPreCategory : IsPreCategory RawFam
|
||||
IsPreCategory.isAssociative isPreCategory
|
||||
{A} {B} {C} {D} {f} {g} {h} = isAssociative {A} {B} {C} {D} {f} {g} {h}
|
||||
IsPreCategory.isIdentity isPreCategory
|
||||
{A} {B} {f} = isIdentity {A} {B} {f = f}
|
||||
IsPreCategory.arrowsAreSets isPreCategory
|
||||
{(A , hA) , famA} {(B , hB) , famB}
|
||||
= setSig
|
||||
{sA = setPi λ _ → hB}
|
||||
{sB = λ f →
|
||||
let
|
||||
helpr : isSet ((a : A) → fst (famA a) → fst (famB (f a)))
|
||||
helpr = setPi λ a → setPi λ _ → snd (famB (f a))
|
||||
-- It's almost like above, but where the first argument is
|
||||
-- implicit.
|
||||
res : isSet ({a : A} → fst (famA a) → fst (famB (f a)))
|
||||
res = {!!}
|
||||
in res
|
||||
}
|
||||
|
||||
isCategory : IsCategory RawFam
|
||||
IsCategory.isPreCategory isCategory = isPreCategory
|
||||
IsCategory.univalent isCategory = {!!}
|
||||
|
||||
Fam : Category (lsuc (ℓa ⊔ ℓb)) (ℓa ⊔ ℓb)
|
||||
Category.raw Fam = RawFam
|
||||
Category.isCategory Fam = isCategory
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
{-# OPTIONS --allow-unsolved-metas #-}
|
||||
{-# OPTIONS --allow-unsolved-metas --cubical #-}
|
||||
module Cat.Categories.Free where
|
||||
|
||||
open import Cat.Prelude hiding (Path ; empty)
|
||||
|
|
@ -27,10 +27,10 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
module ℂ = Category ℂ
|
||||
|
||||
RawFree : RawCategory ℓa (ℓa ⊔ ℓb)
|
||||
RawCategory.Object RawFree = ℂ.Object
|
||||
RawCategory.Arrow RawFree = Path ℂ.Arrow
|
||||
RawCategory.𝟙 RawFree = empty
|
||||
RawCategory._∘_ RawFree = concatenate
|
||||
RawCategory.Object RawFree = ℂ.Object
|
||||
RawCategory.Arrow RawFree = Path ℂ.Arrow
|
||||
RawCategory.identity RawFree = empty
|
||||
RawCategory._<<<_ RawFree = concatenate
|
||||
|
||||
open RawCategory RawFree
|
||||
|
||||
|
|
@ -52,7 +52,7 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
ident-l : ∀ {A} {B} {p : Path ℂ.Arrow A B} → concatenate empty p ≡ p
|
||||
ident-l = refl
|
||||
|
||||
isIdentity : IsIdentity 𝟙
|
||||
isIdentity : IsIdentity identity
|
||||
isIdentity = ident-l , ident-r
|
||||
|
||||
open Univalence isIdentity
|
||||
|
|
@ -61,16 +61,20 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
arrowsAreSets : isSet (Path ℂ.Arrow A B)
|
||||
arrowsAreSets a b p q = {!!}
|
||||
|
||||
eqv : isEquiv (A ≡ B) (A ≅ B) (Univalence.id-to-iso isIdentity A B)
|
||||
isPreCategory : IsPreCategory RawFree
|
||||
IsPreCategory.isAssociative isPreCategory {f = f} {g} {h} = isAssociative {r = f} {g} {h}
|
||||
IsPreCategory.isIdentity isPreCategory = isIdentity
|
||||
IsPreCategory.arrowsAreSets isPreCategory = arrowsAreSets
|
||||
|
||||
module _ {A B : ℂ.Object} where
|
||||
eqv : isEquiv (A ≡ B) (A ≊ B) (Univalence.idToIso isIdentity A B)
|
||||
eqv = {!!}
|
||||
|
||||
univalent : Univalent
|
||||
univalent = eqv
|
||||
|
||||
isCategory : IsCategory RawFree
|
||||
IsCategory.isAssociative isCategory {f = f} {g} {h} = isAssociative {r = f} {g} {h}
|
||||
IsCategory.isIdentity isCategory = isIdentity
|
||||
IsCategory.arrowsAreSets isCategory = arrowsAreSets
|
||||
IsCategory.isPreCategory isCategory = isPreCategory
|
||||
IsCategory.univalent isCategory = univalent
|
||||
|
||||
Free : Category _ _
|
||||
|
|
|
|||
|
|
@ -1,181 +1,219 @@
|
|||
{-# OPTIONS --allow-unsolved-metas --cubical #-}
|
||||
{-# OPTIONS --allow-unsolved-metas --cubical --caching #-}
|
||||
module Cat.Categories.Fun where
|
||||
|
||||
open import Cat.Prelude
|
||||
|
||||
open import Cat.Prelude
|
||||
open import Cat.Equivalence
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor hiding (identity)
|
||||
open import Cat.Category.NaturalTransformation
|
||||
open import Cat.Category.Functor
|
||||
import Cat.Category.NaturalTransformation
|
||||
as NaturalTransformation
|
||||
open import Cat.Categories.Opposite
|
||||
|
||||
module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where
|
||||
module NT = NaturalTransformation ℂ 𝔻
|
||||
open NT public
|
||||
open NaturalTransformation ℂ 𝔻 public hiding (module Properties)
|
||||
private
|
||||
module ℂ = Category ℂ
|
||||
module 𝔻 = Category 𝔻
|
||||
private
|
||||
module _ {A B C D : Functor ℂ 𝔻} {θ' : NaturalTransformation A B}
|
||||
{η' : NaturalTransformation B C} {ζ' : NaturalTransformation C D} where
|
||||
θ = proj₁ θ'
|
||||
η = proj₁ η'
|
||||
ζ = proj₁ ζ'
|
||||
θNat = proj₂ θ'
|
||||
ηNat = proj₂ η'
|
||||
ζNat = proj₂ ζ'
|
||||
L : NaturalTransformation A D
|
||||
L = (NT[_∘_] {A} {C} {D} ζ' (NT[_∘_] {A} {B} {C} η' θ'))
|
||||
R : NaturalTransformation A D
|
||||
R = (NT[_∘_] {A} {B} {D} (NT[_∘_] {B} {C} {D} ζ' η') θ')
|
||||
_g⊕f_ = NT[_∘_] {A} {B} {C}
|
||||
_h⊕g_ = NT[_∘_] {B} {C} {D}
|
||||
isAssociative : L ≡ R
|
||||
isAssociative = lemSig (naturalIsProp {F = A} {D})
|
||||
L R (funExt (λ x → 𝔻.isAssociative))
|
||||
|
||||
private
|
||||
module _ {A B : Functor ℂ 𝔻} {f : NaturalTransformation A B} where
|
||||
allNatural = naturalIsProp {F = A} {B}
|
||||
f' = proj₁ f
|
||||
eq-r : ∀ C → (𝔻 [ f' C ∘ identityTrans A C ]) ≡ f' C
|
||||
eq-r C = begin
|
||||
𝔻 [ f' C ∘ identityTrans A C ] ≡⟨⟩
|
||||
𝔻 [ f' C ∘ 𝔻.𝟙 ] ≡⟨ 𝔻.rightIdentity ⟩
|
||||
f' C ∎
|
||||
eq-l : ∀ C → (𝔻 [ identityTrans B C ∘ f' C ]) ≡ f' C
|
||||
eq-l C = 𝔻.leftIdentity
|
||||
ident-r : (NT[_∘_] {A} {A} {B} f (NT.identity A)) ≡ f
|
||||
ident-r = lemSig allNatural _ _ (funExt eq-r)
|
||||
ident-l : (NT[_∘_] {A} {B} {B} (NT.identity B) f) ≡ f
|
||||
ident-l = lemSig allNatural _ _ (funExt eq-l)
|
||||
isIdentity
|
||||
: (NT[_∘_] {A} {B} {B} (NT.identity B) f) ≡ f
|
||||
× (NT[_∘_] {A} {A} {B} f (NT.identity A)) ≡ f
|
||||
isIdentity = ident-l , ident-r
|
||||
-- Functor categories. Objects are functors, arrows are natural transformations.
|
||||
RawFun : RawCategory (ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd') (ℓc ⊔ ℓc' ⊔ ℓd')
|
||||
RawFun = record
|
||||
{ Object = Functor ℂ 𝔻
|
||||
; Arrow = NaturalTransformation
|
||||
; 𝟙 = λ {F} → NT.identity F
|
||||
; _∘_ = λ {F G H} → NT[_∘_] {F} {G} {H}
|
||||
}
|
||||
module _ where
|
||||
-- Functor categories. Objects are functors, arrows are natural transformations.
|
||||
raw : RawCategory (ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd') (ℓc ⊔ ℓc' ⊔ ℓd')
|
||||
RawCategory.Object raw = Functor ℂ 𝔻
|
||||
RawCategory.Arrow raw = NaturalTransformation
|
||||
RawCategory.identity raw {F} = identity F
|
||||
RawCategory._<<<_ raw {F} {G} {H} = NT[_∘_] {F} {G} {H}
|
||||
|
||||
open RawCategory RawFun
|
||||
open Univalence (λ {A} {B} {f} → isIdentity {A} {B} {f})
|
||||
module _ where
|
||||
open RawCategory raw hiding (identity)
|
||||
open NaturalTransformation.Properties ℂ 𝔻
|
||||
|
||||
isPreCategory : IsPreCategory raw
|
||||
IsPreCategory.isAssociative isPreCategory {A} {B} {C} {D} = isAssociative {A} {B} {C} {D}
|
||||
IsPreCategory.isIdentity isPreCategory {A} {B} = isIdentity {A} {B}
|
||||
IsPreCategory.arrowsAreSets isPreCategory {F} {G} = naturalTransformationIsSet {F} {G}
|
||||
|
||||
open IsPreCategory isPreCategory hiding (identity)
|
||||
|
||||
module _ {F G : Functor ℂ 𝔻} (p : F ≡ G) where
|
||||
private
|
||||
module F = Functor F
|
||||
module G = Functor G
|
||||
p-omap : F.omap ≡ G.omap
|
||||
p-omap = cong Functor.omap p
|
||||
pp : {C : ℂ.Object} → 𝔻 [ Functor.omap F C , Functor.omap F C ] ≡ 𝔻 [ Functor.omap F C , Functor.omap G C ]
|
||||
pp {C} = cong (λ f → 𝔻 [ Functor.omap F C , f C ]) p-omap
|
||||
module _ {C : ℂ.Object} where
|
||||
p* : F.omap C ≡ G.omap C
|
||||
p* = cong (_$ C) p-omap
|
||||
iso : F.omap C 𝔻.≊ G.omap C
|
||||
iso = 𝔻.idToIso _ _ p*
|
||||
open Σ iso renaming (fst to f→g) public
|
||||
open Σ (snd iso) renaming (fst to g→f ; snd to inv) public
|
||||
lem : coe (pp {C}) 𝔻.identity ≡ f→g
|
||||
lem = trans (𝔻.9-1-9-right {b = Functor.omap F C} 𝔻.identity p*) 𝔻.rightIdentity
|
||||
|
||||
-- idToNatTrans : NaturalTransformation F G
|
||||
-- idToNatTrans = (λ C → coe pp 𝔻.identity) , λ f → begin
|
||||
-- coe pp 𝔻.identity 𝔻.<<< F.fmap f ≡⟨ cong (𝔻._<<< F.fmap f) lem ⟩
|
||||
-- -- Just need to show that f→g is a natural transformation
|
||||
-- -- I know that it has an inverse; g→f
|
||||
-- f→g 𝔻.<<< F.fmap f ≡⟨ {!lem!} ⟩
|
||||
-- G.fmap f 𝔻.<<< f→g ≡⟨ cong (G.fmap f 𝔻.<<<_) (sym lem) ⟩
|
||||
-- G.fmap f 𝔻.<<< coe pp 𝔻.identity ∎
|
||||
|
||||
private
|
||||
module _ {A B : Functor ℂ 𝔻} where
|
||||
module A = Functor A
|
||||
module B = Functor B
|
||||
module _ (p : A ≡ B) where
|
||||
omapP : A.omap ≡ B.omap
|
||||
omapP i = Functor.omap (p i)
|
||||
|
||||
coerceAB : ∀ {X} → 𝔻 [ A.omap X , A.omap X ] ≡ 𝔻 [ A.omap X , B.omap X ]
|
||||
coerceAB {X} = cong (λ φ → 𝔻 [ A.omap X , φ X ]) omapP
|
||||
|
||||
-- The transformation will be the identity on 𝔻. Such an arrow has the
|
||||
-- type `A.omap A → A.omap A`. Which we can coerce to have the type
|
||||
-- `A.omap → B.omap` since `A` and `B` are equal.
|
||||
coe𝟙 : Transformation A B
|
||||
coe𝟙 X = coe coerceAB 𝔻.𝟙
|
||||
|
||||
module _ {a b : ℂ.Object} (f : ℂ [ a , b ]) where
|
||||
nat' : 𝔻 [ coe𝟙 b ∘ A.fmap f ] ≡ 𝔻 [ B.fmap f ∘ coe𝟙 a ]
|
||||
nat' = begin
|
||||
(𝔻 [ coe𝟙 b ∘ A.fmap f ]) ≡⟨ {!!} ⟩
|
||||
(𝔻 [ B.fmap f ∘ coe𝟙 a ]) ∎
|
||||
|
||||
transs : (i : I) → Transformation A (p i)
|
||||
transs = {!!}
|
||||
|
||||
natt : (i : I) → Natural A (p i) {!!}
|
||||
natt = {!!}
|
||||
|
||||
t : Natural A B coe𝟙
|
||||
t = coe c (identityNatural A)
|
||||
module _ (iso : A ≊ B) where
|
||||
omapEq : A.omap ≡ B.omap
|
||||
omapEq = funExt eq
|
||||
where
|
||||
c : Natural A A (identityTrans A) ≡ Natural A B coe𝟙
|
||||
c = begin
|
||||
Natural A A (identityTrans A) ≡⟨ (λ x → {!natt ?!}) ⟩
|
||||
Natural A B coe𝟙 ∎
|
||||
-- cong (λ φ → {!Natural A A (identityTrans A)!}) {!!}
|
||||
module _ (C : ℂ.Object) where
|
||||
f : 𝔻.Arrow (A.omap C) (B.omap C)
|
||||
f = fst (fst iso) C
|
||||
g : 𝔻.Arrow (B.omap C) (A.omap C)
|
||||
g = fst (fst (snd iso)) C
|
||||
inv : 𝔻.IsInverseOf f g
|
||||
inv
|
||||
= ( begin
|
||||
g 𝔻.<<< f ≡⟨ cong (λ x → fst x $ C) (fst (snd (snd iso))) ⟩
|
||||
𝔻.identity ∎
|
||||
)
|
||||
, ( begin
|
||||
f 𝔻.<<< g ≡⟨ cong (λ x → fst x $ C) (snd (snd (snd iso))) ⟩
|
||||
𝔻.identity ∎
|
||||
)
|
||||
isoC : A.omap C 𝔻.≊ B.omap C
|
||||
isoC = f , g , inv
|
||||
eq : A.omap C ≡ B.omap C
|
||||
eq = 𝔻.isoToId isoC
|
||||
|
||||
k : Natural A A (identityTrans A) → Natural A B coe𝟙
|
||||
k n {a} {b} f = res
|
||||
where
|
||||
res : (𝔻 [ coe𝟙 b ∘ A.fmap f ]) ≡ (𝔻 [ B.fmap f ∘ coe𝟙 a ])
|
||||
res = {!!}
|
||||
|
||||
nat : Natural A B coe𝟙
|
||||
nat = nat'
|
||||
U : (F : ℂ.Object → 𝔻.Object) → Set _
|
||||
U F = {A B : ℂ.Object} → ℂ [ A , B ] → 𝔻 [ F A , F B ]
|
||||
|
||||
fromEq : NaturalTransformation A B
|
||||
fromEq = coe𝟙 , nat
|
||||
-- module _
|
||||
-- (omap : ℂ.Object → 𝔻.Object)
|
||||
-- (p : A.omap ≡ omap)
|
||||
-- where
|
||||
-- D : Set _
|
||||
-- D = ( fmap : U omap)
|
||||
-- → ( let
|
||||
-- raw-B : RawFunctor ℂ 𝔻
|
||||
-- raw-B = record { omap = omap ; fmap = fmap }
|
||||
-- )
|
||||
-- → (isF-B' : IsFunctor ℂ 𝔻 raw-B)
|
||||
-- → ( let
|
||||
-- B' : Functor ℂ 𝔻
|
||||
-- B' = record { raw = raw-B ; isFunctor = isF-B' }
|
||||
-- )
|
||||
-- → (iso' : A ≊ B') → PathP (λ i → U (p i)) A.fmap fmap
|
||||
-- -- D : Set _
|
||||
-- -- D = PathP (λ i → U (p i)) A.fmap fmap
|
||||
-- -- eeq : (λ f → A.fmap f) ≡ fmap
|
||||
-- -- eeq = funExtImp (λ A → funExtImp (λ B → funExt (λ f → isofmap {A} {B} f)))
|
||||
-- -- where
|
||||
-- -- module _ {X : ℂ.Object} {Y : ℂ.Object} (f : ℂ [ X , Y ]) where
|
||||
-- -- isofmap : A.fmap f ≡ fmap f
|
||||
-- -- isofmap = {!ap!}
|
||||
-- d : D A.omap refl
|
||||
-- d = res
|
||||
-- where
|
||||
-- module _
|
||||
-- ( fmap : U A.omap )
|
||||
-- ( let
|
||||
-- raw-B : RawFunctor ℂ 𝔻
|
||||
-- raw-B = record { omap = A.omap ; fmap = fmap }
|
||||
-- )
|
||||
-- ( isF-B' : IsFunctor ℂ 𝔻 raw-B )
|
||||
-- ( let
|
||||
-- B' : Functor ℂ 𝔻
|
||||
-- B' = record { raw = raw-B ; isFunctor = isF-B' }
|
||||
-- )
|
||||
-- ( iso' : A ≊ B' )
|
||||
-- where
|
||||
-- module _ {X Y : ℂ.Object} (f : ℂ [ X , Y ]) where
|
||||
-- step : {!!} 𝔻.≊ {!!}
|
||||
-- step = {!!}
|
||||
-- resres : A.fmap {X} {Y} f ≡ fmap {X} {Y} f
|
||||
-- resres = {!!}
|
||||
-- res : PathP (λ i → U A.omap) A.fmap fmap
|
||||
-- res i {X} {Y} f = resres f i
|
||||
|
||||
module _ {A B : Functor ℂ 𝔻} where
|
||||
obverse : A ≡ B → A ≅ B
|
||||
obverse p = res
|
||||
where
|
||||
ob : Arrow A B
|
||||
ob = fromEq p
|
||||
re : Arrow B A
|
||||
re = fromEq (sym p)
|
||||
vr : _∘_ {A = A} {B} {A} re ob ≡ 𝟙 {A}
|
||||
vr = {!!}
|
||||
rv : _∘_ {A = B} {A} {B} ob re ≡ 𝟙 {B}
|
||||
rv = {!!}
|
||||
isInverse : IsInverseOf {A} {B} ob re
|
||||
isInverse = vr , rv
|
||||
iso : Isomorphism {A} {B} ob
|
||||
iso = re , isInverse
|
||||
res : A ≅ B
|
||||
res = ob , iso
|
||||
-- fmapEq : PathP (λ i → U (omapEq i)) A.fmap B.fmap
|
||||
-- fmapEq = pathJ D d B.omap omapEq B.fmap B.isFunctor iso
|
||||
|
||||
reverse : A ≅ B → A ≡ B
|
||||
reverse iso = {!!}
|
||||
-- rawEq : A.raw ≡ B.raw
|
||||
-- rawEq i = record { omap = omapEq i ; fmap = fmapEq i }
|
||||
|
||||
ve-re : (y : A ≅ B) → obverse (reverse y) ≡ y
|
||||
ve-re = {!!}
|
||||
-- private
|
||||
-- f : (A ≡ B) → (A ≊ B)
|
||||
-- f p = idToNatTrans p , idToNatTrans (sym p) , NaturalTransformation≡ A A (funExt (λ C → {!!})) , {!!}
|
||||
-- g : (A ≊ B) → (A ≡ B)
|
||||
-- g = Functor≡ ∘ rawEq
|
||||
-- inv : AreInverses f g
|
||||
-- inv = {!funExt λ p → ?!} , {!!}
|
||||
postulate
|
||||
iso : (A ≡ B) ≅ (A ≊ B)
|
||||
-- iso = f , g , inv
|
||||
|
||||
re-ve : (x : A ≡ B) → reverse (obverse x) ≡ x
|
||||
re-ve = {!!}
|
||||
univ : (A ≡ B) ≃ (A ≊ B)
|
||||
univ = fromIsomorphism _ _ iso
|
||||
|
||||
done : isEquiv (A ≡ B) (A ≅ B) (Univalence.id-to-iso (λ { {A} {B} → isIdentity {A} {B}}) A B)
|
||||
done = {!gradLemma obverse reverse ve-re re-ve!}
|
||||
-- There used to be some work-in-progress on this theorem, please go back to
|
||||
-- this point in time to see it:
|
||||
--
|
||||
-- commit 6b7d66b7fc936fe3674b2fd9fa790bd0e3fec12f
|
||||
-- Author: Frederik Hanghøj Iversen <fhi.1990@gmail.com>
|
||||
-- Date: Fri Apr 13 15:26:46 2018 +0200
|
||||
univalent : Univalent
|
||||
univalent = univalenceFrom≃ univ
|
||||
|
||||
univalent : Univalent
|
||||
univalent = done
|
||||
|
||||
instance
|
||||
isCategory : IsCategory RawFun
|
||||
isCategory = record
|
||||
{ isAssociative = λ {A B C D} → isAssociative {A} {B} {C} {D}
|
||||
; isIdentity = λ {A B} → isIdentity {A} {B}
|
||||
; arrowsAreSets = λ {F} {G} → naturalTransformationIsSet {F} {G}
|
||||
; univalent = univalent
|
||||
}
|
||||
isCategory : IsCategory raw
|
||||
IsCategory.isPreCategory isCategory = isPreCategory
|
||||
IsCategory.univalent isCategory = univalent
|
||||
|
||||
Fun : Category (ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd') (ℓc ⊔ ℓc' ⊔ ℓd')
|
||||
Category.raw Fun = RawFun
|
||||
Category.raw Fun = raw
|
||||
Category.isCategory Fun = isCategory
|
||||
|
||||
module _ {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') where
|
||||
private
|
||||
open import Cat.Categories.Sets
|
||||
open NaturalTransformation (opposite ℂ) (𝓢𝓮𝓽 ℓ')
|
||||
module K = Fun (opposite ℂ) (𝓢𝓮𝓽 ℓ')
|
||||
module F = Category K.Fun
|
||||
|
||||
-- Restrict the functors to Presheafs.
|
||||
rawPresh : RawCategory (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ')
|
||||
rawPresh = record
|
||||
raw : RawCategory (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ')
|
||||
raw = record
|
||||
{ Object = Presheaf ℂ
|
||||
; Arrow = NaturalTransformation
|
||||
; 𝟙 = λ {F} → identity F
|
||||
; _∘_ = λ {F G H} → NT[_∘_] {F = F} {G = G} {H = H}
|
||||
; identity = λ {F} → identity F
|
||||
; _<<<_ = λ {F G H} → NT[_∘_] {F = F} {G = G} {H = H}
|
||||
}
|
||||
instance
|
||||
isCategory : IsCategory rawPresh
|
||||
isCategory = Fun.isCategory _ _
|
||||
|
||||
Presh : Category (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ')
|
||||
Category.raw Presh = rawPresh
|
||||
Category.isCategory Presh = isCategory
|
||||
-- isCategory : IsCategory raw
|
||||
-- isCategory = record
|
||||
-- { isAssociative =
|
||||
-- λ{ {A} {B} {C} {D} {f} {g} {h}
|
||||
-- → F.isAssociative {A} {B} {C} {D} {f} {g} {h}
|
||||
-- }
|
||||
-- ; isIdentity =
|
||||
-- λ{ {A} {B} {f}
|
||||
-- → F.isIdentity {A} {B} {f}
|
||||
-- }
|
||||
-- ; arrowsAreSets =
|
||||
-- λ{ {A} {B}
|
||||
-- → F.arrowsAreSets {A} {B}
|
||||
-- }
|
||||
-- ; univalent =
|
||||
-- λ{ {A} {B}
|
||||
-- → F.univalent {A} {B}
|
||||
-- }
|
||||
-- }
|
||||
|
||||
-- Presh : Category (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ')
|
||||
-- Category.raw Presh = raw
|
||||
-- Category.isCategory Presh = isCategory
|
||||
|
|
|
|||
|
|
@ -0,0 +1,96 @@
|
|||
{-# OPTIONS --cubical #-}
|
||||
module Cat.Categories.Opposite where
|
||||
|
||||
open import Cat.Prelude
|
||||
open import Cat.Equivalence
|
||||
open import Cat.Category
|
||||
|
||||
-- | The opposite category
|
||||
--
|
||||
-- The opposite category is the category where the direction of the arrows are
|
||||
-- flipped.
|
||||
module _ {ℓa ℓb : Level} where
|
||||
module _ (ℂ : Category ℓa ℓb) where
|
||||
private
|
||||
module _ where
|
||||
module ℂ = Category ℂ
|
||||
opRaw : RawCategory ℓa ℓb
|
||||
RawCategory.Object opRaw = ℂ.Object
|
||||
RawCategory.Arrow opRaw = flip ℂ.Arrow
|
||||
RawCategory.identity opRaw = ℂ.identity
|
||||
RawCategory._<<<_ opRaw = ℂ._>>>_
|
||||
|
||||
open RawCategory opRaw
|
||||
|
||||
isPreCategory : IsPreCategory opRaw
|
||||
IsPreCategory.isAssociative isPreCategory = sym ℂ.isAssociative
|
||||
IsPreCategory.isIdentity isPreCategory = swap ℂ.isIdentity
|
||||
IsPreCategory.arrowsAreSets isPreCategory = ℂ.arrowsAreSets
|
||||
|
||||
open IsPreCategory isPreCategory
|
||||
|
||||
module _ {A B : ℂ.Object} where
|
||||
open Σ (toIso _ _ (ℂ.univalent {A} {B}))
|
||||
renaming (fst to idToIso* ; snd to inv*)
|
||||
open AreInverses {f = ℂ.idToIso A B} {idToIso*} inv*
|
||||
|
||||
shuffle : A ≊ B → A ℂ.≊ B
|
||||
shuffle (f , g , inv) = g , f , inv
|
||||
|
||||
shuffle~ : A ℂ.≊ B → A ≊ B
|
||||
shuffle~ (f , g , inv) = g , f , inv
|
||||
|
||||
lem : (p : A ≡ B) → idToIso A B p ≡ shuffle~ (ℂ.idToIso A B p)
|
||||
lem p = isoEq refl
|
||||
|
||||
isoToId* : A ≊ B → A ≡ B
|
||||
isoToId* = idToIso* ∘ shuffle
|
||||
|
||||
inv : AreInverses (idToIso A B) isoToId*
|
||||
inv =
|
||||
( funExt (λ x → begin
|
||||
(isoToId* ∘ idToIso A B) x
|
||||
≡⟨⟩
|
||||
(idToIso* ∘ shuffle ∘ idToIso A B) x
|
||||
≡⟨ cong (λ φ → φ x) (cong (λ φ → idToIso* ∘ shuffle ∘ φ) (funExt lem)) ⟩
|
||||
(idToIso* ∘ shuffle ∘ shuffle~ ∘ ℂ.idToIso A B) x
|
||||
≡⟨⟩
|
||||
(idToIso* ∘ ℂ.idToIso A B) x
|
||||
≡⟨ (λ i → verso-recto i x) ⟩
|
||||
x ∎)
|
||||
, funExt (λ x → begin
|
||||
(idToIso A B ∘ idToIso* ∘ shuffle) x
|
||||
≡⟨ cong (λ φ → φ x) (cong (λ φ → φ ∘ idToIso* ∘ shuffle) (funExt lem)) ⟩
|
||||
(shuffle~ ∘ ℂ.idToIso A B ∘ idToIso* ∘ shuffle) x
|
||||
≡⟨ cong (λ φ → φ x) (cong (λ φ → shuffle~ ∘ φ ∘ shuffle) recto-verso) ⟩
|
||||
(shuffle~ ∘ shuffle) x
|
||||
≡⟨⟩
|
||||
x ∎)
|
||||
)
|
||||
|
||||
isCategory : IsCategory opRaw
|
||||
IsCategory.isPreCategory isCategory = isPreCategory
|
||||
IsCategory.univalent isCategory
|
||||
= univalenceFromIsomorphism (isoToId* , inv)
|
||||
|
||||
opposite : Category ℓa ℓb
|
||||
Category.raw opposite = opRaw
|
||||
Category.isCategory opposite = isCategory
|
||||
|
||||
-- As demonstrated here a side-effect of having no-eta-equality on constructors
|
||||
-- means that we need to pick things apart to show that things are indeed
|
||||
-- definitionally equal. I.e; a thing that would normally be provable in one
|
||||
-- line now takes 13!! Admittedly it's a simple proof.
|
||||
module _ {ℂ : Category ℓa ℓb} where
|
||||
open Category ℂ
|
||||
private
|
||||
-- Since they really are definitionally equal we just need to pick apart
|
||||
-- the data-type.
|
||||
rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw
|
||||
RawCategory.Object (rawInv _) = Object
|
||||
RawCategory.Arrow (rawInv _) = Arrow
|
||||
RawCategory.identity (rawInv _) = identity
|
||||
RawCategory._<<<_ (rawInv _) = _<<<_
|
||||
|
||||
oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ
|
||||
oppositeIsInvolution = Category≡ rawInv
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
{-# OPTIONS --cubical --allow-unsolved-metas #-}
|
||||
module Cat.Categories.Rel where
|
||||
|
||||
open import Cat.Prelude renaming (proj₁ to fst ; proj₂ to snd)
|
||||
open import Function
|
||||
open import Cat.Prelude hiding (Rel)
|
||||
open import Cat.Equivalence
|
||||
|
||||
open import Cat.Category
|
||||
|
||||
|
|
@ -62,15 +62,9 @@ module _ {A B : Set} {S : Subset (A × B)} (ab : A × B) 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₁))
|
||||
|
||||
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
|
||||
|
||||
equi : (Σ[ a' ∈ A ] (a , a') ∈ Diag A × (a' , b) ∈ S)
|
||||
≃ (a , b) ∈ S
|
||||
equi = backwards , isequiv
|
||||
equi = fromIsomorphism _ _ (backwards , forwards , funExt bwd-fwd , funExt fwd-bwd)
|
||||
|
||||
ident-r : (Σ[ a' ∈ A ] (a , a') ∈ Diag A × (a' , b) ∈ S)
|
||||
≡ (a , b) ∈ S
|
||||
|
|
@ -96,15 +90,9 @@ module _ {A B : Set} {S : Subset (A × B)} (ab : A × B) 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))
|
||||
|
||||
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
|
||||
|
||||
equi : (Σ[ b' ∈ B ] (a , b') ∈ S × (b' , b) ∈ Diag B)
|
||||
≃ ab ∈ S
|
||||
equi = backwards , isequiv
|
||||
equi = fromIsomorphism _ _ (backwards , (forwards , funExt fwd-bwd , funExt bwd-fwd))
|
||||
|
||||
ident-l : (Σ[ b' ∈ B ] (a , b') ∈ S × (b' , b) ∈ Diag B)
|
||||
≡ ab ∈ S
|
||||
|
|
@ -134,15 +122,9 @@ module _ {A B C D : Set} {S : Subset (A × B)} {R : Subset (B × C)} {Q : Subset
|
|||
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 , isequiv
|
||||
equi = fromIsomorphism _ _ (fwd , bwd , funExt bwd-fwd , funExt fwd-bwd)
|
||||
|
||||
-- isAssociativec : Q + (R + S) ≡ (Q + R) + S
|
||||
is-isAssociative : (Σ[ c ∈ C ] (Σ[ b ∈ B ] (a , b) ∈ S × (b , c) ∈ R) × (c , d) ∈ Q)
|
||||
|
|
@ -153,14 +135,15 @@ RawRel : RawCategory (lsuc lzero) (lsuc lzero)
|
|||
RawRel = record
|
||||
{ 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 )}
|
||||
; identity = λ {S} → Diag S
|
||||
; _<<<_ = λ {A B C} S R → λ {( a , c ) → Σ[ b ∈ B ] ( (a , b) ∈ R × (b , c) ∈ S )}
|
||||
}
|
||||
|
||||
RawIsCategoryRel : IsCategory RawRel
|
||||
RawIsCategoryRel = record
|
||||
{ isAssociative = funExt is-isAssociative
|
||||
; isIdentity = funExt ident-l , funExt ident-r
|
||||
; arrowsAreSets = {!!}
|
||||
; univalent = {!!}
|
||||
}
|
||||
isPreCategory : IsPreCategory RawRel
|
||||
|
||||
IsPreCategory.isAssociative isPreCategory = funExt is-isAssociative
|
||||
IsPreCategory.isIdentity isPreCategory = funExt ident-l , funExt ident-r
|
||||
IsPreCategory.arrowsAreSets isPreCategory = {!!}
|
||||
|
||||
Rel : PreCategory RawRel
|
||||
PreCategory.isPreCategory Rel = isPreCategory
|
||||
|
|
|
|||
|
|
@ -1,23 +1,13 @@
|
|||
-- | The category of homotopy sets
|
||||
{-# OPTIONS --allow-unsolved-metas --cubical --caching #-}
|
||||
{-# OPTIONS --cubical --caching #-}
|
||||
module Cat.Categories.Sets where
|
||||
|
||||
open import Cat.Prelude hiding (_≃_)
|
||||
import Data.Product
|
||||
|
||||
open import Function using (_∘_ ; _∘′_)
|
||||
|
||||
open import Cubical.Univalence using (univalence ; con ; _≃_ ; idtoeqv ; ua)
|
||||
|
||||
open import Cat.Prelude as P
|
||||
open import Cat.Equivalence
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor
|
||||
open import Cat.Category.Product
|
||||
open import Cat.Wishlist
|
||||
open import Cat.Equivalence as Eqv using (AreInverses ; module Equiv≃ ; module NoEta)
|
||||
|
||||
open NoEta
|
||||
|
||||
module Equivalence = Equivalence′
|
||||
open import Cat.Categories.Opposite
|
||||
|
||||
_⊙_ : {ℓa ℓb ℓc : Level} {A : Set ℓa} {B : Set ℓb} {C : Set ℓc} → (A ≃ B) → (B ≃ C) → A ≃ C
|
||||
eqA ⊙ eqB = Equivalence.compose eqA eqB
|
||||
|
|
@ -27,268 +17,46 @@ sym≃ = Equivalence.symmetry
|
|||
|
||||
infixl 10 _⊙_
|
||||
|
||||
module _ {ℓ : Level} {A : Set ℓ} {a : A} where
|
||||
id-coe : coe refl a ≡ a
|
||||
id-coe = begin
|
||||
coe refl a ≡⟨⟩
|
||||
pathJ (λ y x → A) _ A refl ≡⟨ pathJprop {x = a} (λ y x → A) _ ⟩
|
||||
_ ≡⟨ pathJprop {x = a} (λ y x → A) _ ⟩
|
||||
a ∎
|
||||
|
||||
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
|
||||
|
||||
module _ (ℓ : Level) where
|
||||
private
|
||||
SetsRaw : RawCategory (lsuc ℓ) ℓ
|
||||
RawCategory.Object SetsRaw = hSet ℓ
|
||||
RawCategory.Arrow SetsRaw (T , _) (U , _) = T → U
|
||||
RawCategory.𝟙 SetsRaw = Function.id
|
||||
RawCategory._∘_ SetsRaw = Function._∘′_
|
||||
RawCategory.Object SetsRaw = hSet ℓ
|
||||
RawCategory.Arrow SetsRaw (T , _) (U , _) = T → U
|
||||
RawCategory.identity SetsRaw = idFun _
|
||||
RawCategory._<<<_ SetsRaw = _∘′_
|
||||
|
||||
open RawCategory SetsRaw hiding (_∘_)
|
||||
module _ where
|
||||
private
|
||||
open RawCategory SetsRaw hiding (_<<<_)
|
||||
|
||||
isIdentity : IsIdentity Function.id
|
||||
proj₁ isIdentity = funExt λ _ → refl
|
||||
proj₂ isIdentity = funExt λ _ → refl
|
||||
isIdentity : IsIdentity (idFun _)
|
||||
fst isIdentity = funExt λ _ → refl
|
||||
snd isIdentity = funExt λ _ → refl
|
||||
|
||||
open Univalence (λ {A} {B} {f} → isIdentity {A} {B} {f})
|
||||
arrowsAreSets : ArrowsAreSets
|
||||
arrowsAreSets {B = (_ , s)} = setPi λ _ → s
|
||||
|
||||
arrowsAreSets : ArrowsAreSets
|
||||
arrowsAreSets {B = (_ , s)} = setPi λ _ → s
|
||||
|
||||
isIso = Eqv.Isomorphism
|
||||
module _ {hA hB : hSet ℓ} where
|
||||
open Σ hA renaming (proj₁ to A ; proj₂ to sA)
|
||||
open Σ hB renaming (proj₁ to B ; proj₂ to sB)
|
||||
lem1 : (f : A → B) → isSet A → isSet B → isProp (isIso f)
|
||||
lem1 f sA sB = res
|
||||
where
|
||||
module _ (x y : isIso f) where
|
||||
module x = Σ x renaming (proj₁ to inverse ; proj₂ to areInverses)
|
||||
module y = Σ y renaming (proj₁ to inverse ; proj₂ to areInverses)
|
||||
module xA = AreInverses x.areInverses
|
||||
module yA = AreInverses 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 = record
|
||||
{ verso-recto = ve-re
|
||||
; recto-verso = re-ve
|
||||
}
|
||||
where
|
||||
module xxA = AreInverses xx
|
||||
module yyA = AreInverses yy
|
||||
ve-re : g ∘ f ≡ Function.id
|
||||
ve-re = arrowsAreSets {A = hA} {B = hA} _ _ xxA.verso-recto yyA.verso-recto i
|
||||
re-ve : f ∘ g ≡ Function.id
|
||||
re-ve = arrowsAreSets {A = hB} {B = hB} _ _ xxA.recto-verso yyA.recto-verso i
|
||||
1eq : x.inverse ≡ y.inverse
|
||||
1eq = begin
|
||||
x.inverse ≡⟨⟩
|
||||
x.inverse ∘ Function.id ≡⟨ cong (λ φ → x.inverse ∘ φ) (sym yA.recto-verso) ⟩
|
||||
x.inverse ∘ (f ∘ y.inverse) ≡⟨⟩
|
||||
(x.inverse ∘ f) ∘ y.inverse ≡⟨ cong (λ φ → φ ∘ y.inverse) xA.verso-recto ⟩
|
||||
Function.id ∘ 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
|
||||
module _ {ℓa ℓb : Level} {A : Set ℓa} {P : A → Set ℓb} where
|
||||
lem2 : ((x : A) → isProp (P x)) → (p q : Σ A P)
|
||||
→ (p ≡ q) ≃ (proj₁ p ≡ proj₁ q)
|
||||
lem2 pA p q = fromIsomorphism iso
|
||||
where
|
||||
f : ∀ {p q} → p ≡ q → proj₁ p ≡ proj₁ q
|
||||
f e i = proj₁ (e i)
|
||||
g : ∀ {p q} → proj₁ p ≡ proj₁ 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 .proj₁ , propSet (pA (p .proj₁)) (p .proj₂) (p .proj₂) (λ i → (g {p} {p} ∘ f) (λ i₁ → p) i .proj₂) (λ i → p .proj₂) i j ) q
|
||||
re-ve : (e : proj₁ p ≡ proj₁ q) → (f {p} {q} ∘ g {p} {q}) e ≡ e
|
||||
re-ve e = refl
|
||||
inv : AreInverses (f {p} {q}) (g {p} {q})
|
||||
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 : ∀ {ℓc} {Q : A → Set (ℓc ⊔ ℓb)}
|
||||
→ ((a : A) → P a ≃ Q a) → Σ A P ≃ Σ A Q
|
||||
lem3 {Q = Q} eA = res
|
||||
where
|
||||
f : Σ A P → Σ A Q
|
||||
f (a , pA) = a , _≃_.eqv (eA a) pA
|
||||
g : Σ A Q → Σ A P
|
||||
g (a , qA) = a , g' qA
|
||||
where
|
||||
k : Eqv.Isomorphism _
|
||||
k = Equiv≃.toIso _ _ (_≃_.isEqv (eA a))
|
||||
open Σ k renaming (proj₁ to g')
|
||||
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) ≡⟨⟩
|
||||
proj₂ (g (f (a , pA))) ≡⟨⟩
|
||||
g' (_≃_.eqv (eA a) pA) ≡⟨ lem ⟩
|
||||
pA ∎
|
||||
where
|
||||
open Σ x renaming (proj₁ to a ; proj₂ to pA)
|
||||
k : Eqv.Isomorphism _
|
||||
k = Equiv≃.toIso _ _ (_≃_.isEqv (eA a))
|
||||
open Σ k renaming (proj₁ to g' ; proj₂ to inv)
|
||||
module A = AreInverses inv
|
||||
-- anti-funExt
|
||||
lem : (g' ∘ (_≃_.eqv (eA a))) pA ≡ pA
|
||||
lem i = A.verso-recto i pA
|
||||
re-ve : (x : Σ A Q) → (f ∘ g) x ≡ x
|
||||
re-ve x i = proj₁ x , eq i
|
||||
where
|
||||
open Σ x renaming (proj₁ to a ; proj₂ to qA)
|
||||
eq = begin
|
||||
proj₂ ((f ∘ g) x) ≡⟨⟩
|
||||
_≃_.eqv (eA a) (g' qA) ≡⟨ (λ i → A.recto-verso i qA) ⟩
|
||||
qA ∎
|
||||
where
|
||||
k : Eqv.Isomorphism _
|
||||
k = Equiv≃.toIso _ _ (_≃_.isEqv (eA a))
|
||||
open Σ k renaming (proj₁ to g' ; proj₂ to inv)
|
||||
module A = AreInverses inv
|
||||
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 = fromIsomorphism iso
|
||||
|
||||
module _ {ℓa ℓb : Level} {A : Set ℓa} {B : Set ℓb} where
|
||||
lem4 : isSet A → isSet B → (f : A → B)
|
||||
→ isEquiv A B f ≃ isIso f
|
||||
lem4 sA sB f =
|
||||
let
|
||||
obv : isEquiv A B f → isIso f
|
||||
obv = Equiv≃.toIso A B
|
||||
inv : isIso f → isEquiv A B f
|
||||
inv = Equiv≃.fromIso A B
|
||||
re-ve : (x : isEquiv A B f) → (inv ∘ obv) x ≡ x
|
||||
re-ve = Equiv≃.inverse-from-to-iso A B
|
||||
ve-re : (x : isIso f) → (obv ∘ inv) x ≡ x
|
||||
ve-re = Equiv≃.inverse-to-from-iso A B sA sB
|
||||
iso : isEquiv A B f Eqv.≅ isIso f
|
||||
iso = obv , inv ,
|
||||
record
|
||||
{ verso-recto = funExt re-ve
|
||||
; recto-verso = funExt ve-re
|
||||
}
|
||||
in fromIsomorphism iso
|
||||
isPreCat : IsPreCategory SetsRaw
|
||||
IsPreCategory.isAssociative isPreCat = refl
|
||||
IsPreCategory.isIdentity isPreCat {A} {B} = isIdentity {A} {B}
|
||||
IsPreCategory.arrowsAreSets isPreCat {A} {B} = arrowsAreSets {A} {B}
|
||||
|
||||
open IsPreCategory isPreCat
|
||||
module _ {hA hB : Object} where
|
||||
open Σ hA renaming (proj₁ to A ; proj₂ to sA)
|
||||
open Σ hB renaming (proj₁ to B ; proj₂ to sB)
|
||||
open Σ hA renaming (fst to A ; snd to sA)
|
||||
open Σ hB renaming (fst to B ; snd to sB)
|
||||
|
||||
-- lem3 and the equivalence from lem4
|
||||
step0 : Σ (A → B) isIso ≃ Σ (A → B) (isEquiv A B)
|
||||
step0 = lem3 {ℓc = lzero} (λ f → sym≃ (lem4 sA sB f))
|
||||
|
||||
-- univalence
|
||||
step1 : Σ (A → B) (isEquiv A B) ≃ (A ≡ B)
|
||||
step1 = hh ⊙ h
|
||||
where
|
||||
h : (A ≃ B) ≃ (A ≡ B)
|
||||
h = sym≃ (univalence {A = A} {B})
|
||||
obv : Σ (A → B) (isEquiv A B) → A ≃ B
|
||||
obv = Eqv.deEta
|
||||
inv : A ≃ B → Σ (A → B) (isEquiv A B)
|
||||
inv = Eqv.doEta
|
||||
re-ve : (x : _) → (inv ∘ obv) x ≡ x
|
||||
re-ve x = refl
|
||||
-- Because _≃_ does not have eta equality!
|
||||
ve-re : (x : _) → (obv ∘ inv) x ≡ x
|
||||
ve-re (con eqv isEqv) i = con eqv isEqv
|
||||
areInv : AreInverses obv inv
|
||||
areInv = record { verso-recto = funExt re-ve ; recto-verso = funExt ve-re }
|
||||
eqv : Σ (A → B) (isEquiv A B) Eqv.≅ (A ≃ B)
|
||||
eqv = obv , inv , areInv
|
||||
hh : Σ (A → B) (isEquiv A B) ≃ (A ≃ B)
|
||||
hh = fromIsomorphism eqv
|
||||
|
||||
-- lem2 with propIsSet
|
||||
step2 : (A ≡ B) ≃ (hA ≡ hB)
|
||||
step2 = sym≃ (lem2 (λ A → isSetIsProp) hA hB)
|
||||
|
||||
-- Go from an isomorphism on sets to an isomorphism on homotopic sets
|
||||
trivial? : (hA ≅ hB) ≃ (A Eqv.≅ B)
|
||||
trivial? = sym≃ (fromIsomorphism res)
|
||||
where
|
||||
fwd : Σ (A → B) isIso → hA ≅ hB
|
||||
fwd (f , g , inv) = f , g , inv.toPair
|
||||
where
|
||||
module inv = AreInverses inv
|
||||
bwd : hA ≅ hB → Σ (A → B) isIso
|
||||
bwd (f , g , x , y) = f , g , record { verso-recto = x ; recto-verso = y }
|
||||
res : Σ (A → B) isIso Eqv.≅ (hA ≅ hB)
|
||||
res = fwd , bwd , record { verso-recto = refl ; recto-verso = refl }
|
||||
|
||||
conclusion : (hA ≅ hB) ≃ (hA ≡ hB)
|
||||
conclusion = trivial? ⊙ step0 ⊙ step1 ⊙ step2
|
||||
|
||||
univ≃ : (hA ≅ hB) ≃ (hA ≡ hB)
|
||||
univ≃ = trivial? ⊙ step0 ⊙ step1 ⊙ step2
|
||||
|
||||
module _ (hA : Object) where
|
||||
open Σ hA renaming (proj₁ to A)
|
||||
|
||||
eq1 : (Σ[ hB ∈ Object ] hA ≅ hB) ≡ (Σ[ hB ∈ Object ] hA ≡ hB)
|
||||
eq1 = ua (lem3 (\ hB → univ≃))
|
||||
|
||||
univalent[Contr] : isContr (Σ[ hB ∈ Object ] hA ≅ hB)
|
||||
univalent[Contr] = subst {P = isContr} (sym eq1) tres
|
||||
where
|
||||
module _ (y : Σ[ hB ∈ Object ] hA ≡ hB) where
|
||||
open Σ y renaming (proj₁ to hB ; proj₂ to hA≡hB)
|
||||
qres : (hA , refl) ≡ (hB , hA≡hB)
|
||||
qres = contrSingl hA≡hB
|
||||
|
||||
tres : isContr (Σ[ hB ∈ Object ] hA ≡ hB)
|
||||
tres = (hA , refl) , qres
|
||||
univ≃ : (hA ≡ hB) ≃ (hA ≊ hB)
|
||||
univ≃
|
||||
= equivSigProp (λ A → isSetIsProp)
|
||||
⊙ univalence
|
||||
⊙ equivSig {P = isEquiv A B} {Q = TypeIsomorphism} (equiv≃iso sA sB)
|
||||
|
||||
univalent : Univalent
|
||||
univalent = from[Contr] univalent[Contr]
|
||||
univalent = univalenceFrom≃ univ≃
|
||||
|
||||
SetsIsCategory : IsCategory SetsRaw
|
||||
IsCategory.isAssociative SetsIsCategory = refl
|
||||
IsCategory.isIdentity SetsIsCategory {A} {B} = isIdentity {A} {B}
|
||||
IsCategory.arrowsAreSets SetsIsCategory {A} {B} = arrowsAreSets {A} {B}
|
||||
IsCategory.isPreCategory SetsIsCategory = isPreCat
|
||||
IsCategory.univalent SetsIsCategory = univalent
|
||||
|
||||
𝓢𝓮𝓽 Sets : Category (lsuc ℓ) ℓ
|
||||
|
|
@ -300,11 +68,10 @@ module _ {ℓ : Level} where
|
|||
private
|
||||
𝓢 = 𝓢𝓮𝓽 ℓ
|
||||
open Category 𝓢
|
||||
open import Cubical.Sigma
|
||||
|
||||
module _ (hA hB : Object) where
|
||||
open Σ hA renaming (proj₁ to A ; proj₂ to sA)
|
||||
open Σ hB renaming (proj₁ to B ; proj₂ to sB)
|
||||
open Σ hA renaming (fst to A ; snd to sA)
|
||||
open Σ hB renaming (fst to B ; snd to sB)
|
||||
|
||||
private
|
||||
productObject : Object
|
||||
|
|
@ -315,20 +82,32 @@ module _ {ℓ : Level} where
|
|||
_&&&_ x = f x , g x
|
||||
|
||||
module _ (hX : Object) where
|
||||
open Σ hX renaming (proj₁ to X)
|
||||
open Σ hX renaming (fst to X)
|
||||
module _ (f : X → A ) (g : X → B) where
|
||||
ump : proj₁ Function.∘′ (f &&& g) ≡ f × proj₂ Function.∘′ (f &&& g) ≡ g
|
||||
proj₁ ump = refl
|
||||
proj₂ ump = refl
|
||||
ump : fst ∘′ (f &&& g) ≡ f × snd ∘′ (f &&& g) ≡ g
|
||||
fst ump = refl
|
||||
snd ump = refl
|
||||
|
||||
rawProduct : RawProduct 𝓢 hA hB
|
||||
RawProduct.object rawProduct = productObject
|
||||
RawProduct.proj₁ rawProduct = Data.Product.proj₁
|
||||
RawProduct.proj₂ rawProduct = Data.Product.proj₂
|
||||
RawProduct.fst rawProduct = fst
|
||||
RawProduct.snd rawProduct = snd
|
||||
|
||||
isProduct : IsProduct 𝓢 _ _ rawProduct
|
||||
IsProduct.ump isProduct {X = hX} f g
|
||||
= (f &&& g) , ump hX f g
|
||||
= f &&& g , ump hX f g , λ eq → funExt (umpUniq eq)
|
||||
where
|
||||
open Σ hX renaming (fst to X) using ()
|
||||
module _ {y : X → A × B} (eq : fst ∘′ y ≡ f × snd ∘′ y ≡ g) (x : X) where
|
||||
p1 : fst ((f &&& g) x) ≡ fst (y x)
|
||||
p1 = begin
|
||||
fst ((f &&& g) x) ≡⟨⟩
|
||||
f x ≡⟨ (λ i → sym (fst eq) i x) ⟩
|
||||
fst (y x) ∎
|
||||
p2 : snd ((f &&& g) x) ≡ snd (y x)
|
||||
p2 = λ i → sym (snd eq) i x
|
||||
umpUniq : (f &&& g) x ≡ y x
|
||||
umpUniq i = p1 i , p2 i
|
||||
|
||||
product : Product 𝓢 hA hB
|
||||
Product.raw product = rawProduct
|
||||
|
|
|
|||
|
|
@ -0,0 +1,170 @@
|
|||
{-# OPTIONS --cubical --caching #-}
|
||||
module Cat.Categories.Span where
|
||||
|
||||
open import Cat.Prelude as P hiding (_×_ ; fst ; snd)
|
||||
open import Cat.Equivalence
|
||||
open import Cat.Category
|
||||
|
||||
module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb)
|
||||
(let module ℂ = Category ℂ) (𝒜 ℬ : ℂ.Object) where
|
||||
|
||||
open P
|
||||
|
||||
private
|
||||
module _ where
|
||||
raw : RawCategory _ _
|
||||
raw = record
|
||||
{ Object = Σ[ X ∈ ℂ.Object ] ℂ.Arrow X 𝒜 × ℂ.Arrow X ℬ
|
||||
; Arrow = λ{ (A , a0 , a1) (B , b0 , b1)
|
||||
→ Σ[ f ∈ ℂ.Arrow A B ]
|
||||
ℂ [ b0 ∘ f ] ≡ a0
|
||||
× ℂ [ b1 ∘ f ] ≡ a1
|
||||
}
|
||||
; identity = λ{ {X , f , g} → ℂ.identity {X} , ℂ.rightIdentity , ℂ.rightIdentity}
|
||||
; _<<<_ = λ { {_ , a0 , a1} {_ , b0 , b1} {_ , c0 , c1} (f , f0 , f1) (g , g0 , g1)
|
||||
→ (f ℂ.<<< g)
|
||||
, (begin
|
||||
ℂ [ c0 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
|
||||
ℂ [ ℂ [ c0 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f0 ⟩
|
||||
ℂ [ b0 ∘ g ] ≡⟨ g0 ⟩
|
||||
a0 ∎
|
||||
)
|
||||
, (begin
|
||||
ℂ [ c1 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
|
||||
ℂ [ ℂ [ c1 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f1 ⟩
|
||||
ℂ [ b1 ∘ g ] ≡⟨ g1 ⟩
|
||||
a1 ∎
|
||||
)
|
||||
}
|
||||
}
|
||||
|
||||
module _ where
|
||||
open RawCategory raw
|
||||
|
||||
propEqs : ∀ {X' : Object}{Y' : Object} (let X , xa , xb = X') (let Y , ya , yb = Y')
|
||||
→ (xy : ℂ.Arrow X Y) → isProp (ℂ [ ya ∘ xy ] ≡ xa × ℂ [ yb ∘ xy ] ≡ xb)
|
||||
propEqs xs = propSig (ℂ.arrowsAreSets _ _) (\ _ → ℂ.arrowsAreSets _ _)
|
||||
|
||||
arrowEq : {X Y : Object} {f g : Arrow X Y} → fst f ≡ fst g → f ≡ g
|
||||
arrowEq {X} {Y} {f} {g} p = λ i → p i , lemPropF propEqs p {snd f} {snd g} i
|
||||
|
||||
isAssociative : IsAssociative
|
||||
isAssociative {f = f , f0 , f1} {g , g0 , g1} {h , h0 , h1} = arrowEq ℂ.isAssociative
|
||||
|
||||
isIdentity : IsIdentity identity
|
||||
isIdentity {AA@(A , a0 , a1)} {BB@(B , b0 , b1)} {f , f0 , f1} = arrowEq ℂ.leftIdentity , arrowEq ℂ.rightIdentity
|
||||
|
||||
arrowsAreSets : ArrowsAreSets
|
||||
arrowsAreSets {X , x0 , x1} {Y , y0 , y1}
|
||||
= sigPresSet ℂ.arrowsAreSets λ a → propSet (propEqs _)
|
||||
|
||||
isPreCat : IsPreCategory raw
|
||||
IsPreCategory.isAssociative isPreCat = isAssociative
|
||||
IsPreCategory.isIdentity isPreCat = isIdentity
|
||||
IsPreCategory.arrowsAreSets isPreCat = arrowsAreSets
|
||||
|
||||
open IsPreCategory isPreCat
|
||||
|
||||
module _ {𝕏 𝕐 : Object} where
|
||||
open Σ 𝕏 renaming (fst to X ; snd to x)
|
||||
open Σ x renaming (fst to xa ; snd to xb)
|
||||
open Σ 𝕐 renaming (fst to Y ; snd to y)
|
||||
open Σ y renaming (fst to ya ; snd to yb)
|
||||
open import Cat.Equivalence using (composeIso) renaming (_≅_ to _≅_)
|
||||
|
||||
-- The proof will be a sequence of isomorphisms between the
|
||||
-- following 4 types:
|
||||
T0 = ((X , xa , xb) ≡ (Y , ya , yb))
|
||||
T1 = (Σ[ p ∈ (X ≡ Y) ] (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb))
|
||||
T2 = Σ (X ℂ.≊ Y) (λ iso
|
||||
→ let p = ℂ.isoToId iso
|
||||
in
|
||||
( PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya)
|
||||
× PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb
|
||||
)
|
||||
T3 = ((X , xa , xb) ≊ (Y , ya , yb))
|
||||
|
||||
step0 : T0 ≅ T1
|
||||
step0
|
||||
= (λ p → cong fst p , cong-d (fst ∘ snd) p , cong-d (snd ∘ snd) p)
|
||||
-- , (λ x → λ i → fst x i , (fst (snd x) i) , (snd (snd x) i))
|
||||
, (λ{ (p , q , r) → Σ≡ p λ i → q i , r i})
|
||||
, funExt (λ{ p → refl})
|
||||
, funExt (λ{ (p , q , r) → refl})
|
||||
|
||||
step1 : T1 ≅ T2
|
||||
step1
|
||||
= symIso
|
||||
(isoSigFst
|
||||
{A = (X ℂ.≊ Y)}
|
||||
{B = (X ≡ Y)}
|
||||
(ℂ.groupoidObject _ _)
|
||||
{Q = \ p → (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb)}
|
||||
ℂ.isoToId
|
||||
(symIso (_ , ℂ.asTypeIso {X} {Y}) .snd)
|
||||
)
|
||||
|
||||
step2 : T2 ≅ T3
|
||||
step2
|
||||
= ( λ{ (iso@(f , f~ , inv-f) , p , q)
|
||||
→ ( f , sym (ℂ.domain-twist-sym iso p) , sym (ℂ.domain-twist-sym iso q))
|
||||
, ( f~ , sym (ℂ.domain-twist iso p) , sym (ℂ.domain-twist iso q))
|
||||
, arrowEq (fst inv-f)
|
||||
, arrowEq (snd inv-f)
|
||||
}
|
||||
)
|
||||
, (λ{ (f , f~ , inv-f , inv-f~) →
|
||||
let
|
||||
iso : X ℂ.≊ Y
|
||||
iso = fst f , fst f~ , cong fst inv-f , cong fst inv-f~
|
||||
p : X ≡ Y
|
||||
p = ℂ.isoToId iso
|
||||
pA : ℂ.Arrow X 𝒜 ≡ ℂ.Arrow Y 𝒜
|
||||
pA = cong (λ x → ℂ.Arrow x 𝒜) p
|
||||
pB : ℂ.Arrow X ℬ ≡ ℂ.Arrow Y ℬ
|
||||
pB = cong (λ x → ℂ.Arrow x ℬ) p
|
||||
k0 = begin
|
||||
coe pB xb ≡⟨ ℂ.coe-dom iso ⟩
|
||||
xb ℂ.<<< fst f~ ≡⟨ snd (snd f~) ⟩
|
||||
yb ∎
|
||||
k1 = begin
|
||||
coe pA xa ≡⟨ ℂ.coe-dom iso ⟩
|
||||
xa ℂ.<<< fst f~ ≡⟨ fst (snd f~) ⟩
|
||||
ya ∎
|
||||
in iso , coe-lem-inv k1 , coe-lem-inv k0})
|
||||
, funExt (λ x → lemSig
|
||||
(λ x → propSig prop0 (λ _ → prop1))
|
||||
_ _
|
||||
(Σ≡ refl (ℂ.propIsomorphism _ _ _)))
|
||||
, funExt (λ{ (f , _) → lemSig propIsomorphism _ _ (Σ≡ refl (propEqs _ _ _))})
|
||||
where
|
||||
prop0 : ∀ {x} → isProp (PathP (λ i → ℂ.Arrow (ℂ.isoToId x i) 𝒜) xa ya)
|
||||
prop0 {x} = pathJ (λ y p → ∀ x → isProp (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa x)) (λ x → ℂ.arrowsAreSets _ _) Y (ℂ.isoToId x) ya
|
||||
prop1 : ∀ {x} → isProp (PathP (λ i → ℂ.Arrow (ℂ.isoToId x i) ℬ) xb yb)
|
||||
prop1 {x} = pathJ (λ y p → ∀ x → isProp (PathP (λ i → ℂ.Arrow (p i) ℬ) xb x)) (λ x → ℂ.arrowsAreSets _ _) Y (ℂ.isoToId x) yb
|
||||
-- One thing to watch out for here is that the isomorphisms going forwards
|
||||
-- must compose to give idToIso
|
||||
iso
|
||||
: ((X , xa , xb) ≡ (Y , ya , yb))
|
||||
≅ ((X , xa , xb) ≊ (Y , ya , yb))
|
||||
iso = step0 ⊙ step1 ⊙ step2
|
||||
where
|
||||
infixl 5 _⊙_
|
||||
_⊙_ = composeIso
|
||||
equiv1
|
||||
: ((X , xa , xb) ≡ (Y , ya , yb))
|
||||
≃ ((X , xa , xb) ≊ (Y , ya , yb))
|
||||
equiv1 = _ , fromIso _ _ (snd iso)
|
||||
|
||||
univalent : Univalent
|
||||
univalent = univalenceFrom≃ equiv1
|
||||
|
||||
isCat : IsCategory raw
|
||||
IsCategory.isPreCategory isCat = isPreCat
|
||||
IsCategory.univalent isCat = univalent
|
||||
|
||||
span : Category _ _
|
||||
span = record
|
||||
{ raw = raw
|
||||
; isCategory = isCat
|
||||
}
|
||||
|
|
@ -12,8 +12,8 @@
|
|||
--
|
||||
-- Data
|
||||
-- ----
|
||||
-- 𝟙; the identity arrow
|
||||
-- _∘_; function composition
|
||||
-- identity; the identity arrow
|
||||
-- _<<<_; function composition
|
||||
--
|
||||
-- Laws
|
||||
-- ----
|
||||
|
|
@ -24,17 +24,15 @@
|
|||
-- ------
|
||||
--
|
||||
-- Propositionality for all laws about the category.
|
||||
{-# OPTIONS --allow-unsolved-metas --cubical #-}
|
||||
{-# OPTIONS --cubical #-}
|
||||
|
||||
module Cat.Category where
|
||||
|
||||
open import Cat.Prelude
|
||||
renaming
|
||||
( proj₁ to fst
|
||||
; proj₂ to snd
|
||||
)
|
||||
|
||||
import Function
|
||||
import Cat.Equivalence
|
||||
open Cat.Equivalence public using () renaming (Isomorphism to TypeIsomorphism)
|
||||
open Cat.Equivalence
|
||||
hiding (preorder≅ ; Isomorphism)
|
||||
|
||||
------------------
|
||||
-- * Categories --
|
||||
|
|
@ -46,25 +44,20 @@ import Function
|
|||
-- about these. The laws defined are the types the propositions - not the
|
||||
-- witnesses to them!
|
||||
record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
no-eta-equality
|
||||
-- no-eta-equality
|
||||
field
|
||||
Object : Set ℓa
|
||||
Arrow : Object → Object → Set ℓb
|
||||
𝟙 : {A : Object} → Arrow A A
|
||||
_∘_ : {A B C : Object} → Arrow B C → Arrow A B → Arrow A C
|
||||
Object : Set ℓa
|
||||
Arrow : Object → Object → Set ℓb
|
||||
identity : {A : Object} → Arrow A A
|
||||
_<<<_ : {A B C : Object} → Arrow B C → Arrow A B → Arrow A C
|
||||
|
||||
infixl 10 _∘_ _>>>_
|
||||
|
||||
-- | Operations on data
|
||||
|
||||
domain : { a b : Object } → Arrow a b → Object
|
||||
domain {a = a} _ = a
|
||||
|
||||
codomain : { a b : Object } → Arrow a b → Object
|
||||
codomain {b = b} _ = b
|
||||
-- infixr 8 _<<<_
|
||||
-- infixl 8 _>>>_
|
||||
infixl 10 _<<<_ _>>>_
|
||||
|
||||
-- | Reverse arrow composition
|
||||
_>>>_ : {A B C : Object} → (Arrow A B) → (Arrow B C) → Arrow A C
|
||||
f >>> g = g ∘ f
|
||||
f >>> g = g <<< f
|
||||
|
||||
-- | Laws about the data
|
||||
|
||||
|
|
@ -72,30 +65,30 @@ record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
|
|||
-- right-hand-side.
|
||||
IsAssociative : Set (ℓa ⊔ ℓb)
|
||||
IsAssociative = ∀ {A B C D} {f : Arrow A B} {g : Arrow B C} {h : Arrow C D}
|
||||
→ h ∘ (g ∘ f) ≡ (h ∘ g) ∘ f
|
||||
→ h <<< (g <<< f) ≡ (h <<< g) <<< f
|
||||
|
||||
IsIdentity : ({A : Object} → Arrow A A) → Set (ℓa ⊔ ℓb)
|
||||
IsIdentity id = {A B : Object} {f : Arrow A B}
|
||||
→ id ∘ f ≡ f × f ∘ id ≡ f
|
||||
→ id <<< f ≡ f × f <<< id ≡ f
|
||||
|
||||
ArrowsAreSets : Set (ℓa ⊔ ℓb)
|
||||
ArrowsAreSets = ∀ {A B : Object} → isSet (Arrow A B)
|
||||
|
||||
IsInverseOf : ∀ {A B} → (Arrow A B) → (Arrow B A) → Set ℓb
|
||||
IsInverseOf = λ f g → g ∘ f ≡ 𝟙 × f ∘ g ≡ 𝟙
|
||||
IsInverseOf = λ f g → g <<< f ≡ identity × f <<< g ≡ identity
|
||||
|
||||
Isomorphism : ∀ {A B} → (f : Arrow A B) → Set ℓb
|
||||
Isomorphism {A} {B} f = Σ[ g ∈ Arrow B A ] IsInverseOf f g
|
||||
|
||||
_≅_ : (A B : Object) → Set ℓb
|
||||
_≅_ A B = Σ[ f ∈ Arrow A B ] (Isomorphism f)
|
||||
_≊_ : (A B : Object) → Set ℓb
|
||||
_≊_ A B = Σ[ f ∈ Arrow A B ] (Isomorphism f)
|
||||
|
||||
module _ {A B : Object} where
|
||||
Epimorphism : {X : Object } → (f : Arrow A B) → Set ℓb
|
||||
Epimorphism {X} f = ( g₀ g₁ : Arrow B X ) → g₀ ∘ f ≡ g₁ ∘ f → g₀ ≡ g₁
|
||||
Epimorphism : (f : Arrow A B) → Set _
|
||||
Epimorphism f = ∀ {X} → (g₀ g₁ : Arrow B X) → g₀ <<< f ≡ g₁ <<< f → g₀ ≡ g₁
|
||||
|
||||
Monomorphism : {X : Object} → (f : Arrow A B) → Set ℓb
|
||||
Monomorphism {X} f = ( g₀ g₁ : Arrow X A ) → f ∘ g₀ ≡ f ∘ g₁ → g₀ ≡ g₁
|
||||
Monomorphism : (f : Arrow A B) → Set _
|
||||
Monomorphism f = ∀ {X} → (g₀ g₁ : Arrow X A) → f <<< g₀ ≡ f <<< g₁ → g₀ ≡ g₁
|
||||
|
||||
IsInitial : Object → Set (ℓa ⊔ ℓb)
|
||||
IsInitial I = {X : Object} → isContr (Arrow I X)
|
||||
|
|
@ -110,139 +103,455 @@ record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
|
|||
Terminal = Σ Object IsTerminal
|
||||
|
||||
-- | Univalence is indexed by a raw category as well as an identity proof.
|
||||
module Univalence (isIdentity : IsIdentity 𝟙) where
|
||||
module Univalence (isIdentity : IsIdentity identity) where
|
||||
-- | The identity isomorphism
|
||||
idIso : (A : Object) → A ≅ A
|
||||
idIso A = 𝟙 , (𝟙 , isIdentity)
|
||||
idIso : (A : Object) → A ≊ A
|
||||
idIso A = identity , identity , isIdentity
|
||||
|
||||
-- | Extract an isomorphism from an equality
|
||||
--
|
||||
-- [HoTT §9.1.4]
|
||||
id-to-iso : (A B : Object) → A ≡ B → A ≅ B
|
||||
id-to-iso A B eq = transp (\ i → A ≅ eq i) (idIso A)
|
||||
idToIso : (A B : Object) → A ≡ B → A ≊ B
|
||||
idToIso A B eq = subst {P = λ X → A ≊ X} eq (idIso A)
|
||||
|
||||
Univalent : Set (ℓa ⊔ ℓb)
|
||||
Univalent = {A B : Object} → isEquiv (A ≡ B) (A ≅ B) (id-to-iso A B)
|
||||
Univalent = {A B : Object} → isEquiv (A ≡ B) (A ≊ B) (idToIso A B)
|
||||
|
||||
univalenceFromIsomorphism : {A B : Object}
|
||||
→ TypeIsomorphism (idToIso A B) → isEquiv (A ≡ B) (A ≊ B) (idToIso A B)
|
||||
univalenceFromIsomorphism = fromIso _ _
|
||||
|
||||
-- A perhaps more readable version of univalence:
|
||||
Univalent≃ = {A B : Object} → (A ≡ B) ≃ (A ≅ B)
|
||||
Univalent≃ = {A B : Object} → (A ≡ B) ≃ (A ≊ B)
|
||||
Univalent≅ = {A B : Object} → (A ≡ B) ≅ (A ≊ B)
|
||||
|
||||
-- | Equivalent formulation of univalence.
|
||||
Univalent[Contr] : Set _
|
||||
Univalent[Contr] = ∀ A → isContr (Σ[ X ∈ Object ] A ≅ X)
|
||||
private
|
||||
-- | Equivalent formulation of univalence.
|
||||
Univalent[Contr] : Set _
|
||||
Univalent[Contr] = ∀ A → isContr (Σ[ X ∈ Object ] A ≊ X)
|
||||
|
||||
-- From: Thierry Coquand <Thierry.Coquand@cse.gu.se>
|
||||
-- Date: Wed, Mar 21, 2018 at 3:12 PM
|
||||
--
|
||||
-- This is not so straight-forward so you can assume it
|
||||
postulate from[Contr] : Univalent[Contr] → Univalent
|
||||
from[Contr] : Univalent[Contr] → Univalent
|
||||
from[Contr] = ContrToUniv.lemma _ _
|
||||
where
|
||||
open import Cubical.Fiberwise
|
||||
|
||||
-- | The mere proposition of being a category.
|
||||
--
|
||||
-- Also defines a few lemmas:
|
||||
--
|
||||
-- iso-is-epi : Isomorphism f → Epimorphism {X = X} f
|
||||
-- iso-is-mono : Isomorphism f → Monomorphism {X = X} f
|
||||
--
|
||||
-- Sans `univalent` this would be what is referred to as a pre-category in
|
||||
-- [HoTT].
|
||||
record IsCategory {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
open RawCategory ℂ public
|
||||
field
|
||||
isAssociative : IsAssociative
|
||||
isIdentity : IsIdentity 𝟙
|
||||
arrowsAreSets : ArrowsAreSets
|
||||
open Univalence isIdentity public
|
||||
field
|
||||
univalent : Univalent
|
||||
univalenceFrom≃ : Univalent≃ → Univalent
|
||||
univalenceFrom≃ = from[Contr] ∘ step
|
||||
where
|
||||
module _ (f : Univalent≃) (A : Object) where
|
||||
lem : Σ Object (A ≡_) ≃ Σ Object (A ≊_)
|
||||
lem = equivSig λ _ → f
|
||||
|
||||
leftIdentity : {A B : Object} {f : Arrow A B} → 𝟙 ∘ f ≡ f
|
||||
leftIdentity {A} {B} {f} = fst (isIdentity {A = A} {B} {f})
|
||||
aux : isContr (Σ Object (A ≡_))
|
||||
aux = (A , refl) , (λ y → contrSingl (snd y))
|
||||
|
||||
rightIdentity : {A B : Object} {f : Arrow A B} → f ∘ 𝟙 ≡ f
|
||||
rightIdentity {A} {B} {f} = snd (isIdentity {A = A} {B} {f})
|
||||
step : isContr (Σ Object (A ≊_))
|
||||
step = equivPreservesNType {n = ⟨-2⟩} lem aux
|
||||
|
||||
------------
|
||||
-- Lemmas --
|
||||
------------
|
||||
univalenceFrom≅ : Univalent≅ → Univalent
|
||||
univalenceFrom≅ x = univalenceFrom≃ $ fromIsomorphism _ _ x
|
||||
|
||||
-- | Relation between iso- epi- and mono- morphisms.
|
||||
module _ {A B : Object} {X : Object} (f : Arrow A B) where
|
||||
iso→epi : Isomorphism f → Epimorphism {X = X} f
|
||||
iso→epi (f- , left-inv , right-inv) g₀ g₁ eq = begin
|
||||
g₀ ≡⟨ sym rightIdentity ⟩
|
||||
g₀ ∘ 𝟙 ≡⟨ cong (_∘_ g₀) (sym right-inv) ⟩
|
||||
g₀ ∘ (f ∘ f-) ≡⟨ isAssociative ⟩
|
||||
(g₀ ∘ f) ∘ f- ≡⟨ cong (λ φ → φ ∘ f-) eq ⟩
|
||||
(g₁ ∘ f) ∘ f- ≡⟨ sym isAssociative ⟩
|
||||
g₁ ∘ (f ∘ f-) ≡⟨ cong (_∘_ g₁) right-inv ⟩
|
||||
g₁ ∘ 𝟙 ≡⟨ rightIdentity ⟩
|
||||
g₁ ∎
|
||||
propUnivalent : isProp Univalent
|
||||
propUnivalent a b i .equiv-proof = propPi (λ iso → propIsContr) (a .equiv-proof) (b .equiv-proof) i
|
||||
|
||||
iso→mono : Isomorphism f → Monomorphism {X = X} f
|
||||
iso→mono (f- , left-inv , right-inv) g₀ g₁ eq =
|
||||
begin
|
||||
g₀ ≡⟨ sym leftIdentity ⟩
|
||||
𝟙 ∘ g₀ ≡⟨ cong (λ φ → φ ∘ g₀) (sym left-inv) ⟩
|
||||
(f- ∘ f) ∘ g₀ ≡⟨ sym isAssociative ⟩
|
||||
f- ∘ (f ∘ g₀) ≡⟨ cong (_∘_ f-) eq ⟩
|
||||
f- ∘ (f ∘ g₁) ≡⟨ isAssociative ⟩
|
||||
(f- ∘ f) ∘ g₁ ≡⟨ cong (λ φ → φ ∘ g₁) left-inv ⟩
|
||||
𝟙 ∘ g₁ ≡⟨ leftIdentity ⟩
|
||||
g₁ ∎
|
||||
module _ {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where
|
||||
record IsPreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
open RawCategory ℂ public
|
||||
field
|
||||
isAssociative : IsAssociative
|
||||
isIdentity : IsIdentity identity
|
||||
arrowsAreSets : ArrowsAreSets
|
||||
open Univalence isIdentity public
|
||||
|
||||
iso→epi×mono : Isomorphism f → Epimorphism {X = X} f × Monomorphism {X = X} f
|
||||
iso→epi×mono iso = iso→epi iso , iso→mono iso
|
||||
leftIdentity : {A B : Object} {f : Arrow A B} → identity <<< f ≡ f
|
||||
leftIdentity {A} {B} {f} = fst (isIdentity {A = A} {B} {f})
|
||||
|
||||
-- | The formulation of univalence expressed with _≃_ is trivially admissable -
|
||||
-- just "forget" the equivalence.
|
||||
univalent≃ : Univalent≃
|
||||
univalent≃ = _ , univalent
|
||||
rightIdentity : {A B : Object} {f : Arrow A B} → f <<< identity ≡ f
|
||||
rightIdentity {A} {B} {f} = snd (isIdentity {A = A} {B} {f})
|
||||
|
||||
------------
|
||||
-- Lemmas --
|
||||
------------
|
||||
|
||||
-- | Relation between iso- epi- and mono- morphisms.
|
||||
module _ {A B : Object} {X : Object} (f : Arrow A B) where
|
||||
iso→epi : Isomorphism f → Epimorphism f
|
||||
iso→epi (f- , left-inv , right-inv) g₀ g₁ eq = begin
|
||||
g₀ ≡⟨ sym rightIdentity ⟩
|
||||
g₀ <<< identity ≡⟨ cong (_<<<_ g₀) (sym right-inv) ⟩
|
||||
g₀ <<< (f <<< f-) ≡⟨ isAssociative ⟩
|
||||
(g₀ <<< f) <<< f- ≡⟨ cong (λ φ → φ <<< f-) eq ⟩
|
||||
(g₁ <<< f) <<< f- ≡⟨ sym isAssociative ⟩
|
||||
g₁ <<< (f <<< f-) ≡⟨ cong (_<<<_ g₁) right-inv ⟩
|
||||
g₁ <<< identity ≡⟨ rightIdentity ⟩
|
||||
g₁ ∎
|
||||
|
||||
iso→mono : Isomorphism f → Monomorphism f
|
||||
iso→mono (f- , left-inv , right-inv) g₀ g₁ eq =
|
||||
begin
|
||||
g₀ ≡⟨ sym leftIdentity ⟩
|
||||
identity <<< g₀ ≡⟨ cong (λ φ → φ <<< g₀) (sym left-inv) ⟩
|
||||
(f- <<< f) <<< g₀ ≡⟨ sym isAssociative ⟩
|
||||
f- <<< (f <<< g₀) ≡⟨ cong (_<<<_ f-) eq ⟩
|
||||
f- <<< (f <<< g₁) ≡⟨ isAssociative ⟩
|
||||
(f- <<< f) <<< g₁ ≡⟨ cong (λ φ → φ <<< g₁) left-inv ⟩
|
||||
identity <<< g₁ ≡⟨ leftIdentity ⟩
|
||||
g₁ ∎
|
||||
|
||||
iso→epi×mono : Isomorphism f → Epimorphism f × Monomorphism f
|
||||
iso→epi×mono iso = iso→epi iso , iso→mono iso
|
||||
|
||||
-- | All projections are propositions.
|
||||
module Propositionality where
|
||||
propIsAssociative : isProp IsAssociative
|
||||
propIsAssociative x y i = arrowsAreSets _ _ x y i
|
||||
propIsAssociative = propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl λ _ → arrowsAreSets _ _))))))
|
||||
|
||||
propIsIdentity : ∀ {f : ∀ {A} → Arrow A A} → isProp (IsIdentity f)
|
||||
propIsIdentity a b i
|
||||
= arrowsAreSets _ _ (fst a) (fst b) i
|
||||
, arrowsAreSets _ _ (snd a) (snd b) i
|
||||
propIsIdentity {id} = propPiImpl (λ _ → propPiImpl λ _ → propPiImpl (λ f →
|
||||
propSig (arrowsAreSets (id <<< f) f) λ _ → arrowsAreSets (f <<< id) f))
|
||||
|
||||
propArrowIsSet : isProp (∀ {A B} → isSet (Arrow A B))
|
||||
propArrowIsSet a b i = isSetIsProp a b i
|
||||
propArrowIsSet = propPiImpl λ _ → propPiImpl (λ _ → isSetIsProp)
|
||||
|
||||
propIsInverseOf : ∀ {A B f g} → isProp (IsInverseOf {A} {B} f g)
|
||||
propIsInverseOf x y = λ i →
|
||||
let
|
||||
h : fst x ≡ fst y
|
||||
h = arrowsAreSets _ _ (fst x) (fst y)
|
||||
hh : snd x ≡ snd y
|
||||
hh = arrowsAreSets _ _ (snd x) (snd y)
|
||||
in h i , hh i
|
||||
propIsInverseOf = propSig (arrowsAreSets _ _) (λ _ → arrowsAreSets _ _)
|
||||
|
||||
module _ {A B : Object} {f : Arrow A B} where
|
||||
isoIsProp : isProp (Isomorphism f)
|
||||
isoIsProp a@(g , η , ε) a'@(g' , η' , ε') =
|
||||
module _ {A B : Object} where
|
||||
propIsomorphism : (f : Arrow A B) → isProp (Isomorphism f)
|
||||
propIsomorphism f a@(g , η , ε) a'@(g' , η' , ε') =
|
||||
lemSig (λ g → propIsInverseOf) a a' geq
|
||||
where
|
||||
geq : g ≡ g'
|
||||
geq = begin
|
||||
g ≡⟨ sym rightIdentity ⟩
|
||||
g ∘ 𝟙 ≡⟨ cong (λ φ → g ∘ φ) (sym ε') ⟩
|
||||
g ∘ (f ∘ g') ≡⟨ isAssociative ⟩
|
||||
(g ∘ f) ∘ g' ≡⟨ cong (λ φ → φ ∘ g') η ⟩
|
||||
𝟙 ∘ g' ≡⟨ leftIdentity ⟩
|
||||
g' ∎
|
||||
g ≡⟨ sym rightIdentity ⟩
|
||||
g <<< identity ≡⟨ cong (λ φ → g <<< φ) (sym ε') ⟩
|
||||
g <<< (f <<< g') ≡⟨ isAssociative ⟩
|
||||
(g <<< f) <<< g' ≡⟨ cong (λ φ → φ <<< g') η ⟩
|
||||
identity <<< g' ≡⟨ leftIdentity ⟩
|
||||
g' ∎
|
||||
|
||||
propUnivalent : isProp Univalent
|
||||
propUnivalent a b i = propPi (λ iso → propIsContr) a b i
|
||||
isoEq : {a b : A ≊ B} → fst a ≡ fst b → a ≡ b
|
||||
isoEq = lemSig propIsomorphism _ _
|
||||
|
||||
propIsInitial : ∀ I → isProp (IsInitial I)
|
||||
propIsInitial I x y i {X} = res X i
|
||||
where
|
||||
module _ (X : Object) where
|
||||
open Σ (x {X}) renaming (fst to fx ; snd to cx)
|
||||
open Σ (y {X}) renaming (fst to fy ; snd to cy)
|
||||
fp : fx ≡ fy
|
||||
fp = cx fy
|
||||
prop : (x : Arrow I X) → isProp (∀ f → x ≡ f)
|
||||
prop x = propPi (λ y → arrowsAreSets x y)
|
||||
cp : (λ i → ∀ f → fp i ≡ f) [ cx ≡ cy ]
|
||||
cp = lemPropF prop fp
|
||||
res : (fx , cx) ≡ (fy , cy)
|
||||
res i = fp i , cp i
|
||||
|
||||
propIsTerminal : ∀ T → isProp (IsTerminal T)
|
||||
propIsTerminal T x y i {X} = res X i
|
||||
where
|
||||
module _ (X : Object) where
|
||||
open Σ (x {X}) renaming (fst to fx ; snd to cx)
|
||||
open Σ (y {X}) renaming (fst to fy ; snd to cy)
|
||||
fp : fx ≡ fy
|
||||
fp = cx fy
|
||||
prop : (x : Arrow X T) → isProp (∀ f → x ≡ f)
|
||||
prop x = propPi (λ y → arrowsAreSets x y)
|
||||
cp : (λ i → ∀ f → fp i ≡ f) [ cx ≡ cy ]
|
||||
cp = lemPropF prop fp
|
||||
res : (fx , cx) ≡ (fy , cy)
|
||||
res i = fp i , cp i
|
||||
|
||||
module _ where
|
||||
private
|
||||
trans≊ : Transitive _≊_
|
||||
trans≊ (f , f~ , f-inv) (g , g~ , g-inv)
|
||||
= g <<< f
|
||||
, f~ <<< g~
|
||||
, ( begin
|
||||
(f~ <<< g~) <<< (g <<< f) ≡⟨ isAssociative ⟩
|
||||
(f~ <<< g~) <<< g <<< f ≡⟨ cong (λ φ → φ <<< f) (sym isAssociative) ⟩
|
||||
f~ <<< (g~ <<< g) <<< f ≡⟨ cong (λ φ → f~ <<< φ <<< f) (fst g-inv) ⟩
|
||||
f~ <<< identity <<< f ≡⟨ cong (λ φ → φ <<< f) rightIdentity ⟩
|
||||
f~ <<< f ≡⟨ fst f-inv ⟩
|
||||
identity ∎
|
||||
)
|
||||
, ( begin
|
||||
g <<< f <<< (f~ <<< g~) ≡⟨ isAssociative ⟩
|
||||
g <<< f <<< f~ <<< g~ ≡⟨ cong (λ φ → φ <<< g~) (sym isAssociative) ⟩
|
||||
g <<< (f <<< f~) <<< g~ ≡⟨ cong (λ φ → g <<< φ <<< g~) (snd f-inv) ⟩
|
||||
g <<< identity <<< g~ ≡⟨ cong (λ φ → φ <<< g~) rightIdentity ⟩
|
||||
g <<< g~ ≡⟨ snd g-inv ⟩
|
||||
identity ∎
|
||||
)
|
||||
isPreorder : IsPreorder _≊_
|
||||
isPreorder = record { isEquivalence = equalityIsEquivalence ; reflexive = idToIso _ _ ; trans = trans≊ }
|
||||
|
||||
preorder≊ : Preorder _ _ _
|
||||
preorder≊ = record { Carrier = Object ; _≈_ = _≡_ ; _∼_ = _≊_ ; isPreorder = isPreorder }
|
||||
|
||||
record PreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
field
|
||||
isPreCategory : IsPreCategory
|
||||
open IsPreCategory isPreCategory public
|
||||
|
||||
-- Definition 9.6.1 in [HoTT]
|
||||
record StrictCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
field
|
||||
preCategory : PreCategory
|
||||
open PreCategory preCategory
|
||||
field
|
||||
objectsAreSets : isSet Object
|
||||
|
||||
record IsCategory : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
field
|
||||
isPreCategory : IsPreCategory
|
||||
open IsPreCategory isPreCategory public
|
||||
field
|
||||
univalent : Univalent
|
||||
|
||||
-- | The formulation of univalence expressed with _≃_ is trivially admissable -
|
||||
-- just "forget" the equivalence.
|
||||
univalent≃ : Univalent≃
|
||||
univalent≃ = _ , univalent
|
||||
|
||||
module _ {A B : Object} where
|
||||
private
|
||||
iso : TypeIsomorphism (idToIso A B)
|
||||
iso = toIso _ _ univalent
|
||||
|
||||
isoToId : (A ≊ B) → (A ≡ B)
|
||||
isoToId = fst iso
|
||||
|
||||
asTypeIso : TypeIsomorphism (idToIso A B)
|
||||
asTypeIso = toIso _ _ univalent
|
||||
|
||||
-- FIXME Rename
|
||||
inverse-from-to-iso' : AreInverses (idToIso A B) isoToId
|
||||
inverse-from-to-iso' = snd iso
|
||||
|
||||
module _ {a b : Object} (f : Arrow a b) where
|
||||
module _ {a' : Object} (p : a ≡ a') where
|
||||
private
|
||||
p~ : Arrow a' a
|
||||
p~ = fst (snd (idToIso _ _ p))
|
||||
|
||||
D : ∀ a'' → a ≡ a'' → Set _
|
||||
D a'' p' = coe (cong (λ x → Arrow x b) p') f ≡ f <<< (fst (snd (idToIso _ _ p')))
|
||||
|
||||
9-1-9-left : coe (cong (λ x → Arrow x b) p) f ≡ f <<< p~
|
||||
9-1-9-left = pathJ D (begin
|
||||
coe refl f ≡⟨ id-coe ⟩
|
||||
f ≡⟨ sym rightIdentity ⟩
|
||||
f <<< identity ≡⟨ cong (f <<<_) (sym subst-neutral) ⟩
|
||||
f <<< _ ≡⟨⟩ _ ∎) a' p
|
||||
|
||||
module _ {b' : Object} (p : b ≡ b') where
|
||||
private
|
||||
p* : Arrow b b'
|
||||
p* = fst (idToIso _ _ p)
|
||||
|
||||
D : ∀ b'' → b ≡ b'' → Set _
|
||||
D b'' p' = coe (cong (λ x → Arrow a x) p') f ≡ fst (idToIso _ _ p') <<< f
|
||||
|
||||
9-1-9-right : coe (cong (λ x → Arrow a x) p) f ≡ p* <<< f
|
||||
9-1-9-right = pathJ D (begin
|
||||
coe refl f ≡⟨ id-coe ⟩
|
||||
f ≡⟨ sym leftIdentity ⟩
|
||||
identity <<< f ≡⟨ cong (_<<< f) (sym subst-neutral) ⟩
|
||||
_ <<< f ∎) b' p
|
||||
|
||||
-- lemma 9.1.9 in hott
|
||||
module _ {a a' b b' : Object}
|
||||
(p : a ≡ a') (q : b ≡ b') (f : Arrow a b)
|
||||
where
|
||||
private
|
||||
q* : Arrow b b'
|
||||
q* = fst (idToIso _ _ q)
|
||||
q~ : Arrow b' b
|
||||
q~ = fst (snd (idToIso _ _ q))
|
||||
p* : Arrow a a'
|
||||
p* = fst (idToIso _ _ p)
|
||||
p~ : Arrow a' a
|
||||
p~ = fst (snd (idToIso _ _ p))
|
||||
pq : Arrow a b ≡ Arrow a' b'
|
||||
pq i = Arrow (p i) (q i)
|
||||
|
||||
U : ∀ b'' → b ≡ b'' → Set _
|
||||
U b'' q' = coe (λ i → Arrow a (q' i)) f ≡ fst (idToIso _ _ q') <<< f <<< (fst (snd (idToIso _ _ refl)))
|
||||
u : coe (λ i → Arrow a b) f ≡ fst (idToIso _ _ refl) <<< f <<< (fst (snd (idToIso _ _ refl)))
|
||||
u = begin
|
||||
coe refl f ≡⟨ id-coe ⟩
|
||||
f ≡⟨ sym leftIdentity ⟩
|
||||
identity <<< f ≡⟨ sym rightIdentity ⟩
|
||||
identity <<< f <<< identity ≡⟨ cong (λ φ → identity <<< f <<< φ) lem ⟩
|
||||
identity <<< f <<< (fst (snd (idToIso _ _ refl))) ≡⟨ cong (λ φ → φ <<< f <<< (fst (snd (idToIso _ _ refl)))) lem ⟩
|
||||
fst (idToIso _ _ refl) <<< f <<< (fst (snd (idToIso _ _ refl))) ∎
|
||||
where
|
||||
lem : ∀ {x} → PathP (λ _ → Arrow x x) identity (fst (idToIso x x refl))
|
||||
lem = sym subst-neutral
|
||||
|
||||
D : ∀ a'' → a ≡ a'' → Set _
|
||||
D a'' p' = coe (λ i → Arrow (p' i) (q i)) f ≡ fst (idToIso b b' q) <<< f <<< (fst (snd (idToIso _ _ p')))
|
||||
|
||||
d : coe (λ i → Arrow a (q i)) f ≡ fst (idToIso b b' q) <<< f <<< (fst (snd (idToIso _ _ refl)))
|
||||
d = pathJ U u b' q
|
||||
|
||||
9-1-9 : coe pq f ≡ q* <<< f <<< p~
|
||||
9-1-9 = pathJ D d a' p
|
||||
|
||||
9-1-9' : coe pq f <<< p* ≡ q* <<< f
|
||||
9-1-9' = begin
|
||||
coe pq f <<< p* ≡⟨ cong (_<<< p*) 9-1-9 ⟩
|
||||
q* <<< f <<< p~ <<< p* ≡⟨ sym isAssociative ⟩
|
||||
q* <<< f <<< (p~ <<< p*) ≡⟨ cong (λ φ → q* <<< f <<< φ) lem ⟩
|
||||
q* <<< f <<< identity ≡⟨ rightIdentity ⟩
|
||||
q* <<< f ∎
|
||||
where
|
||||
lem : p~ <<< p* ≡ identity
|
||||
lem = fst (snd (snd (idToIso _ _ p)))
|
||||
|
||||
module _ {A B X : Object} (iso : A ≊ B) where
|
||||
private
|
||||
p : A ≡ B
|
||||
p = isoToId iso
|
||||
p-dom : Arrow A X ≡ Arrow B X
|
||||
p-dom = cong (λ x → Arrow x X) p
|
||||
p-cod : Arrow X A ≡ Arrow X B
|
||||
p-cod = cong (λ x → Arrow X x) p
|
||||
lem : ∀ {A B} {x : A ≊ B} → idToIso A B (isoToId x) ≡ x
|
||||
lem {x = x} i = snd inverse-from-to-iso' i x
|
||||
|
||||
open Σ iso renaming (fst to ι) using ()
|
||||
open Σ (snd iso) renaming (fst to ι~ ; snd to inv)
|
||||
|
||||
coe-dom : {f : Arrow A X} → coe p-dom f ≡ f <<< ι~
|
||||
coe-dom {f} = begin
|
||||
coe p-dom f ≡⟨ 9-1-9-left f p ⟩
|
||||
f <<< fst (snd (idToIso _ _ (isoToId iso))) ≡⟨⟩
|
||||
f <<< fst (snd (idToIso _ _ p)) ≡⟨ cong (f <<<_) (cong (fst ∘ snd) lem) ⟩
|
||||
f <<< ι~ ∎
|
||||
|
||||
coe-cod : {f : Arrow X A} → coe p-cod f ≡ ι <<< f
|
||||
coe-cod {f} = begin
|
||||
coe p-cod f
|
||||
≡⟨ 9-1-9-right f p ⟩
|
||||
fst (idToIso _ _ p) <<< f
|
||||
≡⟨ cong (λ φ → φ <<< f) (cong fst lem) ⟩
|
||||
ι <<< f ∎
|
||||
|
||||
module _ {f : Arrow A X} {g : Arrow B X} (q : PathP (λ i → p-dom i) f g) where
|
||||
domain-twist : g ≡ f <<< ι~
|
||||
domain-twist = begin
|
||||
g ≡⟨ sym (coe-lem q) ⟩
|
||||
coe p-dom f ≡⟨ coe-dom ⟩
|
||||
f <<< ι~ ∎
|
||||
|
||||
-- This can probably also just be obtained from the above my taking the
|
||||
-- symmetric isomorphism.
|
||||
domain-twist-sym : f ≡ g <<< ι
|
||||
domain-twist-sym = begin
|
||||
f ≡⟨ sym rightIdentity ⟩
|
||||
f <<< identity ≡⟨ cong (f <<<_) (sym (fst inv)) ⟩
|
||||
f <<< (ι~ <<< ι) ≡⟨ isAssociative ⟩
|
||||
f <<< ι~ <<< ι ≡⟨ cong (_<<< ι) (sym domain-twist) ⟩
|
||||
g <<< ι ∎
|
||||
|
||||
-- | All projections are propositions.
|
||||
module Propositionality where
|
||||
-- | Terminal objects are propositional - a.k.a uniqueness of terminal
|
||||
-- | objects.
|
||||
--
|
||||
-- Having two terminal objects induces an isomorphism between them - and
|
||||
-- because of univalence this is equivalent to equality.
|
||||
propTerminal : isProp Terminal
|
||||
propTerminal Xt Yt = res
|
||||
where
|
||||
open Σ Xt renaming (fst to X ; snd to Xit)
|
||||
open Σ Yt renaming (fst to Y ; snd to Yit)
|
||||
open Σ (Xit {Y}) renaming (fst to Y→X) using ()
|
||||
open Σ (Yit {X}) renaming (fst to X→Y) using ()
|
||||
-- Need to show `left` and `right`, what we know is that the arrows are
|
||||
-- unique. Well, I know that if I compose these two arrows they must give
|
||||
-- the identity, since also the identity is the unique such arrow (by X
|
||||
-- and Y both being terminal objects.)
|
||||
Xprop : isProp (Arrow X X)
|
||||
Xprop f g = trans (sym (snd Xit f)) (snd Xit g)
|
||||
Yprop : isProp (Arrow Y Y)
|
||||
Yprop f g = trans (sym (snd Yit f)) (snd Yit g)
|
||||
left : Y→X <<< X→Y ≡ identity
|
||||
left = Xprop _ _
|
||||
right : X→Y <<< Y→X ≡ identity
|
||||
right = Yprop _ _
|
||||
iso : X ≊ Y
|
||||
iso = X→Y , Y→X , left , right
|
||||
p0 : X ≡ Y
|
||||
p0 = isoToId iso
|
||||
p1 : (λ i → IsTerminal (p0 i)) [ Xit ≡ Yit ]
|
||||
p1 = lemPropF propIsTerminal p0
|
||||
res : Xt ≡ Yt
|
||||
res i = p0 i , p1 i
|
||||
|
||||
-- Merely the dual of the above statement.
|
||||
|
||||
propInitial : isProp Initial
|
||||
propInitial Xi Yi = res
|
||||
where
|
||||
open Σ Xi renaming (fst to X ; snd to Xii)
|
||||
open Σ Yi renaming (fst to Y ; snd to Yii)
|
||||
open Σ (Xii {Y}) renaming (fst to Y→X) using ()
|
||||
open Σ (Yii {X}) renaming (fst to X→Y) using ()
|
||||
-- Need to show `left` and `right`, what we know is that the arrows are
|
||||
-- unique. Well, I know that if I compose these two arrows they must give
|
||||
-- the identity, since also the identity is the unique such arrow (by X
|
||||
-- and Y both being terminal objects.)
|
||||
Xprop : isProp (Arrow X X)
|
||||
Xprop f g = trans (sym (snd Xii f)) (snd Xii g)
|
||||
Yprop : isProp (Arrow Y Y)
|
||||
Yprop f g = trans (sym (snd Yii f)) (snd Yii g)
|
||||
left : Y→X <<< X→Y ≡ identity
|
||||
left = Yprop _ _
|
||||
right : X→Y <<< Y→X ≡ identity
|
||||
right = Xprop _ _
|
||||
iso : X ≊ Y
|
||||
iso = Y→X , X→Y , right , left
|
||||
res : Xi ≡ Yi
|
||||
res = lemSig propIsInitial _ _ (isoToId iso)
|
||||
|
||||
groupoidObject : isGrpd Object
|
||||
groupoidObject A B = res
|
||||
where
|
||||
open import Data.Nat using (_≤_ ; ≤′-refl ; ≤′-step)
|
||||
setIso : ∀ x → isSet (Isomorphism x)
|
||||
setIso x = ntypeCumulative {n = 1} (≤′-step ≤′-refl) (propIsomorphism x)
|
||||
step : isSet (A ≊ B)
|
||||
step = setSig {sA = arrowsAreSets} {sB = setIso}
|
||||
res : isSet (A ≡ B)
|
||||
res = equivPreservesNType
|
||||
{A = A ≊ B} {B = A ≡ B} {n = ⟨0⟩}
|
||||
(Equivalence.symmetry (univalent≃ {A = A} {B}))
|
||||
step
|
||||
|
||||
-- | Propositionality of being a category
|
||||
module _ {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where
|
||||
open RawCategory ℂ
|
||||
open Univalence
|
||||
private
|
||||
module _ (x y : IsPreCategory ℂ) where
|
||||
module x = IsPreCategory x
|
||||
module y = IsPreCategory y
|
||||
-- In a few places I use the result of propositionality of the various
|
||||
-- projections of `IsCategory` - Here I arbitrarily chose to use this
|
||||
-- result from `x : IsCategory C`. I don't know which (if any) possibly
|
||||
-- adverse effects this may have.
|
||||
-- module Prop = X.Propositionality
|
||||
|
||||
propIsPreCategory : x ≡ y
|
||||
IsPreCategory.isAssociative (propIsPreCategory i)
|
||||
= x.propIsAssociative x.isAssociative y.isAssociative i
|
||||
IsPreCategory.isIdentity (propIsPreCategory i)
|
||||
= x.propIsIdentity x.isIdentity y.isIdentity i
|
||||
IsPreCategory.arrowsAreSets (propIsPreCategory i)
|
||||
= x.propArrowIsSet x.arrowsAreSets y.arrowsAreSets i
|
||||
|
||||
module _ (x y : IsCategory ℂ) where
|
||||
module X = IsCategory x
|
||||
module Y = IsCategory y
|
||||
|
|
@ -250,39 +559,39 @@ module _ {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where
|
|||
-- projections of `IsCategory` - Here I arbitrarily chose to use this
|
||||
-- result from `x : IsCategory C`. I don't know which (if any) possibly
|
||||
-- adverse effects this may have.
|
||||
module Prop = X.Propositionality
|
||||
|
||||
isIdentity : (λ _ → IsIdentity 𝟙) [ X.isIdentity ≡ Y.isIdentity ]
|
||||
isIdentity = Prop.propIsIdentity X.isIdentity Y.isIdentity
|
||||
U : ∀ {a : IsIdentity 𝟙}
|
||||
→ (λ _ → IsIdentity 𝟙) [ X.isIdentity ≡ a ]
|
||||
→ (b : Univalent a)
|
||||
→ Set _
|
||||
U eqwal univ =
|
||||
(λ i → Univalent (eqwal i))
|
||||
[ X.univalent ≡ univ ]
|
||||
P : (y : IsIdentity 𝟙)
|
||||
→ (λ _ → IsIdentity 𝟙) [ X.isIdentity ≡ y ] → Set _
|
||||
P y eq = ∀ (univ : Univalent y) → U eq univ
|
||||
p : ∀ (b' : Univalent X.isIdentity)
|
||||
→ (λ _ → Univalent X.isIdentity) [ X.univalent ≡ b' ]
|
||||
p univ = Prop.propUnivalent X.univalent univ
|
||||
helper : P Y.isIdentity isIdentity
|
||||
helper = pathJ P p Y.isIdentity isIdentity
|
||||
eqUni : U isIdentity Y.univalent
|
||||
eqUni = helper Y.univalent
|
||||
isIdentity= : (λ _ → IsIdentity identity) [ X.isIdentity ≡ Y.isIdentity ]
|
||||
isIdentity= = X.propIsIdentity X.isIdentity Y.isIdentity
|
||||
|
||||
isPreCategory= : X.isPreCategory ≡ Y.isPreCategory
|
||||
isPreCategory= = propIsPreCategory X.isPreCategory Y.isPreCategory
|
||||
|
||||
private
|
||||
p = cong IsPreCategory.isIdentity isPreCategory=
|
||||
|
||||
univalent= : (λ i → Univalent (p i))
|
||||
[ X.univalent ≡ Y.univalent ]
|
||||
univalent= = lemPropF
|
||||
{A = IsIdentity identity}
|
||||
{B = Univalent}
|
||||
propUnivalent
|
||||
{a0 = X.isIdentity}
|
||||
{a1 = Y.isIdentity}
|
||||
p
|
||||
|
||||
done : x ≡ y
|
||||
IsCategory.isAssociative (done i) = Prop.propIsAssociative X.isAssociative Y.isAssociative i
|
||||
IsCategory.isIdentity (done i) = isIdentity i
|
||||
IsCategory.arrowsAreSets (done i) = Prop.propArrowIsSet X.arrowsAreSets Y.arrowsAreSets i
|
||||
IsCategory.univalent (done i) = eqUni i
|
||||
IsCategory.isPreCategory (done i) = isPreCategory= i
|
||||
IsCategory.univalent (done i) = univalent= i
|
||||
|
||||
propIsCategory : isProp (IsCategory ℂ)
|
||||
propIsCategory = done
|
||||
|
||||
|
||||
-- | Univalent categories
|
||||
--
|
||||
-- Just bundles up the data with witnesses inhabiting the propositions.
|
||||
|
||||
-- Question: Should I remove the type `Category`?
|
||||
record Category (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
|
||||
field
|
||||
raw : RawCategory ℓa ℓb
|
||||
|
|
@ -300,13 +609,11 @@ module _ {ℓa ℓb : Level} {ℂ 𝔻 : Category ℓa ℓb} where
|
|||
module _ (rawEq : ℂ.raw ≡ 𝔻.raw) where
|
||||
private
|
||||
isCategoryEq : (λ i → IsCategory (rawEq i)) [ ℂ.isCategory ≡ 𝔻.isCategory ]
|
||||
isCategoryEq = lemPropF propIsCategory rawEq
|
||||
isCategoryEq = lemPropF {A = RawCategory _ _} {B = IsCategory} propIsCategory rawEq
|
||||
|
||||
Category≡ : ℂ ≡ 𝔻
|
||||
Category≡ i = record
|
||||
{ raw = rawEq i
|
||||
; isCategory = isCategoryEq i
|
||||
}
|
||||
Category.raw (Category≡ i) = rawEq i
|
||||
Category.isCategory (Category≡ i) = isCategoryEq i
|
||||
|
||||
-- | Syntax for arrows- and composition in a given category.
|
||||
module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
|
|
@ -315,68 +622,4 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
_[_,_] = Arrow
|
||||
|
||||
_[_∘_] : {A B C : Object} → (g : Arrow B C) → (f : Arrow A B) → Arrow A C
|
||||
_[_∘_] = _∘_
|
||||
|
||||
-- | The opposite category
|
||||
--
|
||||
-- The opposite category is the category where the direction of the arrows are
|
||||
-- flipped.
|
||||
module Opposite {ℓa ℓb : Level} where
|
||||
module _ (ℂ : Category ℓa ℓb) where
|
||||
private
|
||||
module ℂ = Category ℂ
|
||||
opRaw : RawCategory ℓa ℓb
|
||||
RawCategory.Object opRaw = ℂ.Object
|
||||
RawCategory.Arrow opRaw = Function.flip ℂ.Arrow
|
||||
RawCategory.𝟙 opRaw = ℂ.𝟙
|
||||
RawCategory._∘_ opRaw = Function.flip ℂ._∘_
|
||||
|
||||
open RawCategory opRaw
|
||||
|
||||
isIdentity : IsIdentity 𝟙
|
||||
isIdentity = swap ℂ.isIdentity
|
||||
|
||||
open Univalence isIdentity
|
||||
|
||||
module _ {A B : ℂ.Object} where
|
||||
univalent : isEquiv (A ≡ B) (A ≅ B)
|
||||
(Univalence.id-to-iso (swap ℂ.isIdentity) A B)
|
||||
fst (univalent iso) = flipFiber (fst (ℂ.univalent (flipIso iso)))
|
||||
where
|
||||
flipIso : A ≅ B → B ℂ.≅ A
|
||||
flipIso (f , f~ , iso) = f , f~ , swap iso
|
||||
flipFiber
|
||||
: fiber (ℂ.id-to-iso B A) (flipIso iso)
|
||||
→ fiber ( id-to-iso A B) iso
|
||||
flipFiber (eq , eqIso) = sym eq , {!!}
|
||||
snd (univalent iso) = {!!}
|
||||
|
||||
isCategory : IsCategory opRaw
|
||||
IsCategory.isAssociative isCategory = sym ℂ.isAssociative
|
||||
IsCategory.isIdentity isCategory = isIdentity
|
||||
IsCategory.arrowsAreSets isCategory = ℂ.arrowsAreSets
|
||||
IsCategory.univalent isCategory = univalent
|
||||
|
||||
opposite : Category ℓa ℓb
|
||||
Category.raw opposite = opRaw
|
||||
Category.isCategory opposite = isCategory
|
||||
|
||||
-- As demonstrated here a side-effect of having no-eta-equality on constructors
|
||||
-- means that we need to pick things apart to show that things are indeed
|
||||
-- definitionally equal. I.e; a thing that would normally be provable in one
|
||||
-- line now takes 13!! Admittedly it's a simple proof.
|
||||
module _ {ℂ : Category ℓa ℓb} where
|
||||
open Category ℂ
|
||||
private
|
||||
-- Since they really are definitionally equal we just need to pick apart
|
||||
-- the data-type.
|
||||
rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw
|
||||
RawCategory.Object (rawInv _) = Object
|
||||
RawCategory.Arrow (rawInv _) = Arrow
|
||||
RawCategory.𝟙 (rawInv _) = 𝟙
|
||||
RawCategory._∘_ (rawInv _) = _∘_
|
||||
|
||||
oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ
|
||||
oppositeIsInvolution = Category≡ rawInv
|
||||
|
||||
open Opposite public
|
||||
_[_∘_] = _<<<_
|
||||
|
|
|
|||
|
|
@ -16,11 +16,11 @@ module _ {ℓ ℓ'} (ℂ : Category ℓ ℓ') {{hasProducts : HasProducts ℂ}}
|
|||
field
|
||||
uniq
|
||||
: ∀ (A : Object) (f : ℂ [ A × B , C ])
|
||||
→ ∃![ f~ ] (ℂ [ eval ∘ f~ |×| Category.𝟙 ℂ ] ≡ f)
|
||||
→ ∃![ f~ ] (ℂ [ eval ∘ f~ |×| Category.identity ℂ ] ≡ f)
|
||||
|
||||
IsExponential : (Cᴮ : Object) → ℂ [ Cᴮ × B , C ] → Set (ℓ ⊔ ℓ')
|
||||
IsExponential Cᴮ eval = ∀ (A : Object) (f : ℂ [ A × B , C ])
|
||||
→ ∃![ f~ ] (ℂ [ eval ∘ f~ |×| Category.𝟙 ℂ ] ≡ f)
|
||||
→ ∃![ f~ ] (ℂ [ eval ∘ f~ |×| Category.identity ℂ ] ≡ f)
|
||||
|
||||
record Exponential : Set (ℓ ⊔ ℓ') where
|
||||
field
|
||||
|
|
@ -30,7 +30,7 @@ module _ {ℓ ℓ'} (ℂ : Category ℓ ℓ') {{hasProducts : HasProducts ℂ}}
|
|||
{{isExponential}} : IsExponential obj eval
|
||||
|
||||
transpose : (A : Object) → ℂ [ A × B , C ] → ℂ [ A , obj ]
|
||||
transpose A f = proj₁ (isExponential A f)
|
||||
transpose A f = fst (isExponential A f)
|
||||
|
||||
record HasExponentials {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') {{_ : HasProducts ℂ}} : Set (ℓ ⊔ ℓ') where
|
||||
open Category ℂ
|
||||
|
|
|
|||
|
|
@ -1,39 +1,37 @@
|
|||
{-# OPTIONS --cubical #-}
|
||||
module Cat.Category.Functor where
|
||||
|
||||
open import Agda.Primitive
|
||||
open import Function
|
||||
open import Cat.Prelude
|
||||
|
||||
open import Cubical
|
||||
open import Cubical.NType.Properties using (lemPropF)
|
||||
|
||||
open import Cat.Category
|
||||
|
||||
open Category hiding (_∘_ ; raw ; IsIdentity)
|
||||
|
||||
module _ {ℓc ℓc' ℓd ℓd'}
|
||||
(ℂ : Category ℓc ℓc')
|
||||
(𝔻 : Category ℓd ℓd')
|
||||
where
|
||||
|
||||
private
|
||||
module ℂ = Category ℂ
|
||||
module 𝔻 = Category 𝔻
|
||||
ℓ = ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd'
|
||||
𝓤 = Set ℓ
|
||||
|
||||
Omap = Object ℂ → Object 𝔻
|
||||
Omap = ℂ.Object → 𝔻.Object
|
||||
Fmap : Omap → Set _
|
||||
Fmap omap = ∀ {A B}
|
||||
→ ℂ [ A , B ] → 𝔻 [ omap A , omap B ]
|
||||
record RawFunctor : 𝓤 where
|
||||
field
|
||||
omap : Object ℂ → Object 𝔻
|
||||
omap : ℂ.Object → 𝔻.Object
|
||||
fmap : ∀ {A B} → ℂ [ A , B ] → 𝔻 [ omap A , omap B ]
|
||||
|
||||
IsIdentity : Set _
|
||||
IsIdentity = {A : Object ℂ} → fmap (𝟙 ℂ {A}) ≡ 𝟙 𝔻 {omap A}
|
||||
IsIdentity = {A : ℂ.Object} → fmap (ℂ.identity {A}) ≡ 𝔻.identity {omap A}
|
||||
|
||||
IsDistributive : Set _
|
||||
IsDistributive = {A B C : Object ℂ} {f : ℂ [ A , B ]} {g : ℂ [ B , C ]}
|
||||
IsDistributive = {A B C : ℂ.Object} {f : ℂ [ A , B ]} {g : ℂ [ B , C ]}
|
||||
→ fmap (ℂ [ g ∘ f ]) ≡ 𝔻 [ fmap g ∘ fmap f ]
|
||||
|
||||
-- | Equality principle for raw functors
|
||||
|
|
@ -120,11 +118,18 @@ module _ {ℓc ℓc' ℓd ℓd' : Level} {ℂ : Category ℓc ℓc'} {𝔻 : Cat
|
|||
res : (λ i → IsFunctor ℂ 𝔻 (eq i)) [ isFunctor F ≡ isFunctor G ]
|
||||
res = IsFunctorIsProp' (isFunctor F) (isFunctor G)
|
||||
|
||||
module _ {ℓ ℓ' : Level} {A B C : Category ℓ ℓ'} (F : Functor B C) (G : Functor A B) where
|
||||
module _ {ℓ0 ℓ1 ℓ2 ℓ3 ℓ4 ℓ5 : Level}
|
||||
{A : Category ℓ0 ℓ1}
|
||||
{B : Category ℓ2 ℓ3}
|
||||
{C : Category ℓ4 ℓ5}
|
||||
(F : Functor B C) (G : Functor A B) where
|
||||
private
|
||||
module A = Category A
|
||||
module B = Category B
|
||||
module C = Category C
|
||||
module F = Functor F
|
||||
module G = Functor G
|
||||
module _ {a0 a1 a2 : Object A} {α0 : A [ a0 , a1 ]} {α1 : A [ a1 , a2 ]} where
|
||||
module _ {a0 a1 a2 : A.Object} {α0 : A [ a0 , a1 ]} {α1 : A [ a1 , a2 ]} where
|
||||
dist : (F.fmap ∘ G.fmap) (A [ α1 ∘ α0 ]) ≡ C [ (F.fmap ∘ G.fmap) α1 ∘ (F.fmap ∘ G.fmap) α0 ]
|
||||
dist = begin
|
||||
(F.fmap ∘ G.fmap) (A [ α1 ∘ α0 ])
|
||||
|
|
@ -143,10 +148,10 @@ module _ {ℓ ℓ' : Level} {A B C : Category ℓ ℓ'} (F : Functor B C) (G : F
|
|||
isFunctor : IsFunctor A C raw
|
||||
isFunctor = record
|
||||
{ isIdentity = begin
|
||||
(F.fmap ∘ G.fmap) (𝟙 A) ≡⟨ refl ⟩
|
||||
F.fmap (G.fmap (𝟙 A)) ≡⟨ cong F.fmap (G.isIdentity)⟩
|
||||
F.fmap (𝟙 B) ≡⟨ F.isIdentity ⟩
|
||||
𝟙 C ∎
|
||||
(F.fmap ∘ G.fmap) A.identity ≡⟨ refl ⟩
|
||||
F.fmap (G.fmap A.identity) ≡⟨ cong F.fmap (G.isIdentity)⟩
|
||||
F.fmap B.identity ≡⟨ F.isIdentity ⟩
|
||||
C.identity ∎
|
||||
; isDistributive = dist
|
||||
}
|
||||
|
||||
|
|
@ -154,15 +159,42 @@ module _ {ℓ ℓ' : Level} {A B C : Category ℓ ℓ'} (F : Functor B C) (G : F
|
|||
Functor.raw F[_∘_] = raw
|
||||
Functor.isFunctor F[_∘_] = isFunctor
|
||||
|
||||
-- The identity functor
|
||||
identity : ∀ {ℓ ℓ'} → {C : Category ℓ ℓ'} → Functor C C
|
||||
identity = record
|
||||
{ raw = record
|
||||
{ omap = λ x → x
|
||||
; fmap = λ x → x
|
||||
}
|
||||
; isFunctor = record
|
||||
{ isIdentity = refl
|
||||
; isDistributive = refl
|
||||
}
|
||||
}
|
||||
-- | The identity functor
|
||||
module Functors where
|
||||
module _ {ℓc ℓcc : Level} {ℂ : Category ℓc ℓcc} where
|
||||
private
|
||||
raw : RawFunctor ℂ ℂ
|
||||
RawFunctor.omap raw = idFun _
|
||||
RawFunctor.fmap raw = idFun _
|
||||
|
||||
isFunctor : IsFunctor ℂ ℂ raw
|
||||
IsFunctor.isIdentity isFunctor = refl
|
||||
IsFunctor.isDistributive isFunctor = refl
|
||||
|
||||
identity : Functor ℂ ℂ
|
||||
Functor.raw identity = raw
|
||||
Functor.isFunctor identity = isFunctor
|
||||
|
||||
module _
|
||||
{ℓa ℓaa ℓb ℓbb ℓc ℓcc ℓd ℓdd : Level}
|
||||
{𝔸 : Category ℓa ℓaa}
|
||||
{𝔹 : Category ℓb ℓbb}
|
||||
{ℂ : Category ℓc ℓcc}
|
||||
{𝔻 : Category ℓd ℓdd}
|
||||
{F : Functor 𝔸 𝔹} {G : Functor 𝔹 ℂ} {H : Functor ℂ 𝔻} where
|
||||
isAssociative : F[ H ∘ F[ G ∘ F ] ] ≡ F[ F[ H ∘ G ] ∘ F ]
|
||||
isAssociative = Functor≡ refl
|
||||
|
||||
module _
|
||||
{ℓc ℓcc ℓd ℓdd : Level}
|
||||
{ℂ : Category ℓc ℓcc}
|
||||
{𝔻 : Category ℓd ℓdd}
|
||||
{F : Functor ℂ 𝔻} where
|
||||
leftIdentity : F[ identity ∘ F ] ≡ F
|
||||
leftIdentity = Functor≡ refl
|
||||
|
||||
rightIdentity : F[ F ∘ identity ] ≡ F
|
||||
rightIdentity = Functor≡ refl
|
||||
|
||||
isIdentity : F[ identity ∘ F ] ≡ F × F[ F ∘ identity ] ≡ F
|
||||
isIdentity = leftIdentity , rightIdentity
|
||||
|
|
|
|||
|
|
@ -17,196 +17,224 @@ These two formulations are proven to be equivalent:
|
|||
The monoidal representation is exposed by default from this module.
|
||||
---}
|
||||
|
||||
{-# OPTIONS --cubical --allow-unsolved-metas #-}
|
||||
{-# OPTIONS --cubical #-}
|
||||
module Cat.Category.Monad where
|
||||
|
||||
open import Cat.Prelude
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor as F
|
||||
open import Cat.Category.NaturalTransformation
|
||||
import Cat.Category.NaturalTransformation
|
||||
import Cat.Category.Monad.Monoidal
|
||||
import Cat.Category.Monad.Kleisli
|
||||
open import Cat.Categories.Fun
|
||||
|
||||
module Monoidal = Cat.Category.Monad.Monoidal
|
||||
module Kleisli = Cat.Category.Monad.Kleisli
|
||||
|
||||
-- | The monoidal- and kleisli presentation of monads are equivalent.
|
||||
module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
open Cat.Category.NaturalTransformation ℂ ℂ using (NaturalTransformation ; propIsNatural)
|
||||
private
|
||||
module ℂ = Category ℂ
|
||||
open ℂ using (Object ; Arrow ; 𝟙 ; _∘_ ; _>>>_)
|
||||
module M = Monoidal ℂ
|
||||
module K = Kleisli ℂ
|
||||
open ℂ using (Object ; Arrow ; identity ; _<<<_ ; _>>>_)
|
||||
|
||||
module _ (m : M.RawMonad) where
|
||||
open M.RawMonad m
|
||||
module Monoidal = Cat.Category.Monad.Monoidal ℂ
|
||||
module Kleisli = Cat.Category.Monad.Kleisli ℂ
|
||||
|
||||
forthRaw : K.RawMonad
|
||||
K.RawMonad.omap forthRaw = Romap
|
||||
K.RawMonad.pure forthRaw = pureT _
|
||||
K.RawMonad.bind forthRaw = bind
|
||||
module _ (m : Monoidal.RawMonad) where
|
||||
open Monoidal.RawMonad m
|
||||
|
||||
module _ {raw : M.RawMonad} (m : M.IsMonad raw) where
|
||||
private
|
||||
module MI = M.IsMonad m
|
||||
forthIsMonad : K.IsMonad (forthRaw raw)
|
||||
K.IsMonad.isIdentity forthIsMonad = proj₂ MI.isInverse
|
||||
K.IsMonad.isNatural forthIsMonad = MI.isNatural
|
||||
K.IsMonad.isDistributive forthIsMonad = MI.isDistributive
|
||||
toKleisliRaw : Kleisli.RawMonad
|
||||
Kleisli.RawMonad.omap toKleisliRaw = Romap
|
||||
Kleisli.RawMonad.pure toKleisliRaw = pure
|
||||
Kleisli.RawMonad.bind toKleisliRaw = bind
|
||||
|
||||
forth : M.Monad → K.Monad
|
||||
Kleisli.Monad.raw (forth m) = forthRaw (M.Monad.raw m)
|
||||
Kleisli.Monad.isMonad (forth m) = forthIsMonad (M.Monad.isMonad m)
|
||||
module _ {raw : Monoidal.RawMonad} (m : Monoidal.IsMonad raw) where
|
||||
open Monoidal.IsMonad m
|
||||
|
||||
module _ (m : K.Monad) where
|
||||
open K.Monad m
|
||||
open Kleisli.RawMonad (toKleisliRaw raw) using (_>=>_)
|
||||
toKleisliIsMonad : Kleisli.IsMonad (toKleisliRaw raw)
|
||||
Kleisli.IsMonad.isIdentity toKleisliIsMonad = begin
|
||||
bind pure ≡⟨⟩
|
||||
join <<< (fmap pure) ≡⟨ snd isInverse ⟩
|
||||
identity ∎
|
||||
Kleisli.IsMonad.isNatural toKleisliIsMonad f = begin
|
||||
pure >=> f ≡⟨⟩
|
||||
pure >>> bind f ≡⟨⟩
|
||||
bind f <<< pure ≡⟨⟩
|
||||
(join <<< fmap f) <<< pure ≡⟨ isNatural f ⟩
|
||||
f ∎
|
||||
Kleisli.IsMonad.isDistributive toKleisliIsMonad f g = begin
|
||||
bind g >>> bind f ≡⟨⟩
|
||||
(join <<< fmap f) <<< (join <<< fmap g) ≡⟨ isDistributive f g ⟩
|
||||
join <<< fmap (join <<< fmap f <<< g) ≡⟨⟩
|
||||
bind (g >=> f) ∎
|
||||
-- Kleisli.IsMonad.isDistributive toKleisliIsMonad = isDistributive
|
||||
|
||||
backRaw : M.RawMonad
|
||||
M.RawMonad.R backRaw = R
|
||||
M.RawMonad.pureNT backRaw = pureNT
|
||||
M.RawMonad.joinNT backRaw = joinNT
|
||||
toKleisli : Monoidal.Monad → Kleisli.Monad
|
||||
Kleisli.Monad.raw (toKleisli m) = toKleisliRaw (Monoidal.Monad.raw m)
|
||||
Kleisli.Monad.isMonad (toKleisli m) = toKleisliIsMonad (Monoidal.Monad.isMonad m)
|
||||
|
||||
private
|
||||
open M.RawMonad backRaw
|
||||
module R = Functor (M.RawMonad.R backRaw)
|
||||
module _ (m : Kleisli.Monad) where
|
||||
open Kleisli.Monad m
|
||||
|
||||
backIsMonad : M.IsMonad backRaw
|
||||
M.IsMonad.isAssociative backIsMonad {X} = begin
|
||||
joinT X ∘ R.fmap (joinT X) ≡⟨⟩
|
||||
join ∘ fmap (joinT X) ≡⟨⟩
|
||||
join ∘ fmap join ≡⟨ isNaturalForeign ⟩
|
||||
join ∘ join ≡⟨⟩
|
||||
joinT X ∘ joinT (R.omap X) ∎
|
||||
M.IsMonad.isInverse backIsMonad {X} = inv-l , inv-r
|
||||
toMonoidalRaw : Monoidal.RawMonad
|
||||
Monoidal.RawMonad.R toMonoidalRaw = R
|
||||
Monoidal.RawMonad.pureNT toMonoidalRaw = pureNT
|
||||
Monoidal.RawMonad.joinNT toMonoidalRaw = joinNT
|
||||
|
||||
open Monoidal.RawMonad toMonoidalRaw renaming
|
||||
( join to join*
|
||||
; pure to pure*
|
||||
; bind to bind*
|
||||
; fmap to fmap*
|
||||
) using ()
|
||||
|
||||
toMonoidalIsMonad : Monoidal.IsMonad toMonoidalRaw
|
||||
Monoidal.IsMonad.isAssociative toMonoidalIsMonad = begin
|
||||
join* <<< fmap join* ≡⟨⟩
|
||||
join <<< fmap join ≡⟨ isNaturalForeign ⟩
|
||||
join <<< join ∎
|
||||
Monoidal.IsMonad.isInverse toMonoidalIsMonad {X} = inv-l , inv-r
|
||||
where
|
||||
inv-l = begin
|
||||
joinT X ∘ pureT (R.omap X) ≡⟨⟩
|
||||
join ∘ pure ≡⟨ proj₁ isInverse ⟩
|
||||
𝟙 ∎
|
||||
join <<< pure ≡⟨ fst isInverse ⟩
|
||||
identity ∎
|
||||
inv-r = begin
|
||||
joinT X ∘ R.fmap (pureT X) ≡⟨⟩
|
||||
join ∘ fmap pure ≡⟨ proj₂ isInverse ⟩
|
||||
𝟙 ∎
|
||||
join* <<< fmap* pure* ≡⟨⟩
|
||||
join <<< fmap pure ≡⟨ snd isInverse ⟩
|
||||
identity ∎
|
||||
|
||||
back : K.Monad → M.Monad
|
||||
Monoidal.Monad.raw (back m) = backRaw m
|
||||
Monoidal.Monad.isMonad (back m) = backIsMonad m
|
||||
toMonoidal : Kleisli.Monad → Monoidal.Monad
|
||||
Monoidal.Monad.raw (toMonoidal m) = toMonoidalRaw m
|
||||
Monoidal.Monad.isMonad (toMonoidal m) = toMonoidalIsMonad m
|
||||
|
||||
module _ (m : K.Monad) where
|
||||
module _ (m : Kleisli.Monad) where
|
||||
private
|
||||
open K.Monad m
|
||||
open Kleisli.Monad m
|
||||
bindEq : ∀ {X Y}
|
||||
→ K.RawMonad.bind (forthRaw (backRaw m)) {X} {Y}
|
||||
≡ K.RawMonad.bind (K.Monad.raw m)
|
||||
bindEq {X} {Y} = begin
|
||||
K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩
|
||||
(λ f → join ∘ fmap f) ≡⟨⟩
|
||||
(λ f → bind (f >>> pure) >>> bind 𝟙) ≡⟨ funExt lem ⟩
|
||||
(λ f → bind f) ≡⟨⟩
|
||||
bind ∎
|
||||
→ Kleisli.RawMonad.bind (toKleisliRaw (toMonoidalRaw m)) {X} {Y}
|
||||
≡ bind
|
||||
bindEq {X} {Y} = funExt lem
|
||||
where
|
||||
lem : (f : Arrow X (omap Y))
|
||||
→ bind (f >>> pure) >>> bind 𝟙
|
||||
→ bind (f >>> pure) >>> bind identity
|
||||
≡ bind f
|
||||
lem f = begin
|
||||
bind (f >>> pure) >>> bind 𝟙
|
||||
join <<< fmap f
|
||||
≡⟨⟩
|
||||
bind (f >>> pure) >>> bind identity
|
||||
≡⟨ isDistributive _ _ ⟩
|
||||
bind ((f >>> pure) >>> bind 𝟙)
|
||||
bind ((f >>> pure) >=> identity)
|
||||
≡⟨⟩
|
||||
bind ((f >>> pure) >>> bind identity)
|
||||
≡⟨ cong bind ℂ.isAssociative ⟩
|
||||
bind (f >>> (pure >>> bind 𝟙))
|
||||
bind (f >>> (pure >>> bind identity))
|
||||
≡⟨⟩
|
||||
bind (f >>> (pure >=> identity))
|
||||
≡⟨ cong (λ φ → bind (f >>> φ)) (isNatural _) ⟩
|
||||
bind (f >>> 𝟙)
|
||||
bind (f >>> identity)
|
||||
≡⟨ cong bind ℂ.leftIdentity ⟩
|
||||
bind f ∎
|
||||
|
||||
forthRawEq : forthRaw (backRaw m) ≡ K.Monad.raw m
|
||||
K.RawMonad.omap (forthRawEq _) = omap
|
||||
K.RawMonad.pure (forthRawEq _) = pure
|
||||
K.RawMonad.bind (forthRawEq i) = bindEq i
|
||||
toKleisliRawEq : toKleisliRaw (toMonoidalRaw m) ≡ Kleisli.Monad.raw m
|
||||
Kleisli.RawMonad.omap (toKleisliRawEq i) = (begin
|
||||
Kleisli.RawMonad.omap (toKleisliRaw (toMonoidalRaw m)) ≡⟨⟩
|
||||
Monoidal.RawMonad.Romap (toMonoidalRaw m) ≡⟨⟩
|
||||
omap ∎
|
||||
) i
|
||||
Kleisli.RawMonad.pure (toKleisliRawEq i) = (begin
|
||||
Kleisli.RawMonad.pure (toKleisliRaw (toMonoidalRaw m)) ≡⟨⟩
|
||||
Monoidal.RawMonad.pure (toMonoidalRaw m) ≡⟨⟩
|
||||
pure ∎
|
||||
) i
|
||||
Kleisli.RawMonad.bind (toKleisliRawEq i) = bindEq i
|
||||
|
||||
fortheq : (m : K.Monad) → forth (back m) ≡ m
|
||||
fortheq m = K.Monad≡ (forthRawEq m)
|
||||
toKleislieq : (m : Kleisli.Monad) → toKleisli (toMonoidal m) ≡ m
|
||||
toKleislieq m = Kleisli.Monad≡ (toKleisliRawEq m)
|
||||
|
||||
module _ (m : M.Monad) where
|
||||
module _ (m : Monoidal.Monad) where
|
||||
private
|
||||
open M.Monad m
|
||||
module KM = K.Monad (forth m)
|
||||
open Monoidal.Monad m
|
||||
-- module KM = Kleisli.Monad (toKleisli m)
|
||||
open Kleisli.Monad (toKleisli m) renaming
|
||||
( bind to bind* ; omap to omap* ; join to join*
|
||||
; fmap to fmap* ; pure to pure* ; R to R*)
|
||||
using ()
|
||||
module R = Functor R
|
||||
omapEq : KM.omap ≡ Romap
|
||||
omapEq : omap* ≡ Romap
|
||||
omapEq = refl
|
||||
|
||||
bindEq : ∀ {X Y} {f : Arrow X (Romap Y)} → KM.bind f ≡ bind f
|
||||
bindEq : ∀ {X Y} {f : Arrow X (Romap Y)} → bind* f ≡ bind f
|
||||
bindEq {X} {Y} {f} = begin
|
||||
KM.bind f ≡⟨⟩
|
||||
joinT Y ∘ Rfmap f ≡⟨⟩
|
||||
bind f ∎
|
||||
bind* f ≡⟨⟩
|
||||
join <<< fmap f ≡⟨⟩
|
||||
bind f ∎
|
||||
|
||||
joinEq : ∀ {X} → KM.join ≡ joinT X
|
||||
joinEq : ∀ {X} → join* ≡ joinT X
|
||||
joinEq {X} = begin
|
||||
KM.join ≡⟨⟩
|
||||
KM.bind 𝟙 ≡⟨⟩
|
||||
bind 𝟙 ≡⟨⟩
|
||||
joinT X ∘ Rfmap 𝟙 ≡⟨ cong (λ φ → _ ∘ φ) R.isIdentity ⟩
|
||||
joinT X ∘ 𝟙 ≡⟨ ℂ.rightIdentity ⟩
|
||||
joinT X ∎
|
||||
join* ≡⟨⟩
|
||||
bind* identity ≡⟨⟩
|
||||
bind identity ≡⟨⟩
|
||||
join <<< fmap identity ≡⟨ cong (λ φ → _ <<< φ) R.isIdentity ⟩
|
||||
join <<< identity ≡⟨ ℂ.rightIdentity ⟩
|
||||
join ∎
|
||||
|
||||
fmapEq : ∀ {A B} → KM.fmap {A} {B} ≡ Rfmap
|
||||
fmapEq : ∀ {A B} → fmap* {A} {B} ≡ fmap
|
||||
fmapEq {A} {B} = funExt (λ f → begin
|
||||
KM.fmap f ≡⟨⟩
|
||||
KM.bind (f >>> KM.pure) ≡⟨⟩
|
||||
bind (f >>> pureT _) ≡⟨⟩
|
||||
Rfmap (f >>> pureT B) >>> joinT B ≡⟨⟩
|
||||
Rfmap (f >>> pureT B) >>> joinT B ≡⟨ cong (λ φ → φ >>> joinT B) R.isDistributive ⟩
|
||||
Rfmap f >>> Rfmap (pureT B) >>> joinT B ≡⟨ ℂ.isAssociative ⟩
|
||||
joinT B ∘ Rfmap (pureT B) ∘ Rfmap f ≡⟨ cong (λ φ → φ ∘ Rfmap f) (proj₂ isInverse) ⟩
|
||||
𝟙 ∘ Rfmap f ≡⟨ ℂ.leftIdentity ⟩
|
||||
Rfmap f ∎
|
||||
fmap* f ≡⟨⟩
|
||||
bind* (f >>> pure*) ≡⟨⟩
|
||||
bind (f >>> pure) ≡⟨⟩
|
||||
fmap (f >>> pure) >>> join ≡⟨⟩
|
||||
fmap (f >>> pure) >>> join ≡⟨ cong (λ φ → φ >>> joinT B) R.isDistributive ⟩
|
||||
fmap f >>> fmap pure >>> join ≡⟨ ℂ.isAssociative ⟩
|
||||
join <<< fmap pure <<< fmap f ≡⟨ cong (λ φ → φ <<< fmap f) (snd isInverse) ⟩
|
||||
identity <<< fmap f ≡⟨ ℂ.leftIdentity ⟩
|
||||
fmap f ∎
|
||||
)
|
||||
|
||||
rawEq : Functor.raw KM.R ≡ Functor.raw R
|
||||
rawEq : Functor.raw R* ≡ Functor.raw R
|
||||
RawFunctor.omap (rawEq i) = omapEq i
|
||||
RawFunctor.fmap (rawEq i) = fmapEq i
|
||||
|
||||
Req : M.RawMonad.R (backRaw (forth m)) ≡ R
|
||||
Req : Monoidal.RawMonad.R (toMonoidalRaw (toKleisli m)) ≡ R
|
||||
Req = Functor≡ rawEq
|
||||
|
||||
open NaturalTransformation ℂ ℂ
|
||||
pureTEq : Monoidal.RawMonad.pureT (toMonoidalRaw (toKleisli m)) ≡ pureT
|
||||
pureTEq = refl
|
||||
|
||||
pureTEq : M.RawMonad.pureT (backRaw (forth m)) ≡ pureT
|
||||
pureTEq = funExt (λ X → refl)
|
||||
pureNTEq : (λ i → NaturalTransformation Functors.identity (Req i))
|
||||
[ Monoidal.RawMonad.pureNT (toMonoidalRaw (toKleisli m)) ≡ pureNT ]
|
||||
pureNTEq = lemSigP (λ i → propIsNatural Functors.identity (Req i)) _ _ pureTEq
|
||||
|
||||
pureNTEq : (λ i → NaturalTransformation F.identity (Req i))
|
||||
[ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ]
|
||||
pureNTEq = lemSigP (λ i → propIsNatural F.identity (Req i)) _ _ pureTEq
|
||||
|
||||
joinTEq : M.RawMonad.joinT (backRaw (forth m)) ≡ joinT
|
||||
joinTEq : Monoidal.RawMonad.joinT (toMonoidalRaw (toKleisli m)) ≡ joinT
|
||||
joinTEq = funExt (λ X → begin
|
||||
M.RawMonad.joinT (backRaw (forth m)) X ≡⟨⟩
|
||||
KM.join ≡⟨⟩
|
||||
joinT X ∘ Rfmap 𝟙 ≡⟨ cong (λ φ → joinT X ∘ φ) R.isIdentity ⟩
|
||||
joinT X ∘ 𝟙 ≡⟨ ℂ.rightIdentity ⟩
|
||||
joinT X ∎)
|
||||
Monoidal.RawMonad.joinT (toMonoidalRaw (toKleisli m)) X ≡⟨⟩
|
||||
join* ≡⟨⟩
|
||||
join <<< fmap identity ≡⟨ cong (λ φ → join <<< φ) R.isIdentity ⟩
|
||||
join <<< identity ≡⟨ ℂ.rightIdentity ⟩
|
||||
join ∎)
|
||||
|
||||
joinNTEq : (λ i → NaturalTransformation F[ Req i ∘ Req i ] (Req i))
|
||||
[ M.RawMonad.joinNT (backRaw (forth m)) ≡ joinNT ]
|
||||
[ Monoidal.RawMonad.joinNT (toMonoidalRaw (toKleisli m)) ≡ joinNT ]
|
||||
joinNTEq = lemSigP (λ i → propIsNatural F[ Req i ∘ Req i ] (Req i)) _ _ joinTEq
|
||||
|
||||
backRawEq : backRaw (forth m) ≡ M.Monad.raw m
|
||||
M.RawMonad.R (backRawEq i) = Req i
|
||||
M.RawMonad.pureNT (backRawEq i) = pureNTEq i
|
||||
M.RawMonad.joinNT (backRawEq i) = joinNTEq i
|
||||
toMonoidalRawEq : toMonoidalRaw (toKleisli m) ≡ Monoidal.Monad.raw m
|
||||
Monoidal.RawMonad.R (toMonoidalRawEq i) = Req i
|
||||
Monoidal.RawMonad.pureNT (toMonoidalRawEq i) = pureNTEq i
|
||||
Monoidal.RawMonad.joinNT (toMonoidalRawEq i) = joinNTEq i
|
||||
|
||||
backeq : (m : M.Monad) → back (forth m) ≡ m
|
||||
backeq m = M.Monad≡ (backRawEq m)
|
||||
|
||||
eqv : isEquiv M.Monad K.Monad forth
|
||||
eqv = gradLemma forth back fortheq backeq
|
||||
toMonoidaleq : (m : Monoidal.Monad) → toMonoidal (toKleisli m) ≡ m
|
||||
toMonoidaleq m = Monoidal.Monad≡ (toMonoidalRawEq m)
|
||||
|
||||
open import Cat.Equivalence
|
||||
|
||||
Monoidal≅Kleisli : M.Monad ≅ K.Monad
|
||||
Monoidal≅Kleisli = forth , (back , (record { verso-recto = funExt backeq ; recto-verso = funExt fortheq }))
|
||||
Monoidal≊Kleisli : Monoidal.Monad ≅ Kleisli.Monad
|
||||
Monoidal≊Kleisli = toKleisli , toMonoidal , funExt toMonoidaleq , funExt toKleislieq
|
||||
|
||||
Monoidal≃Kleisli : M.Monad ≃ K.Monad
|
||||
Monoidal≃Kleisli = forth , eqv
|
||||
Monoidal≡Kleisli : Monoidal.Monad ≡ Kleisli.Monad
|
||||
Monoidal≡Kleisli = isoToPath Monoidal≊Kleisli
|
||||
|
||||
grpdKleisli : isGrpd Kleisli.Monad
|
||||
grpdKleisli = Kleisli.grpdMonad
|
||||
|
||||
grpdMonoidal : isGrpd Monoidal.Monad
|
||||
grpdMonoidal = subst {P = isGrpd}
|
||||
(sym Monoidal≡Kleisli) grpdKleisli
|
||||
|
|
|
|||
|
|
@ -1,22 +1,25 @@
|
|||
{---
|
||||
The Kleisli formulation of monads
|
||||
---}
|
||||
{-# OPTIONS --cubical --allow-unsolved-metas #-}
|
||||
{-# OPTIONS --cubical #-}
|
||||
open import Agda.Primitive
|
||||
|
||||
open import Cat.Prelude
|
||||
open import Cat.Equivalence
|
||||
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor as F
|
||||
open import Cat.Category.NaturalTransformation
|
||||
open import Cat.Categories.Fun
|
||||
|
||||
-- "A monad in the Kleisli form" [voe]
|
||||
module Cat.Category.Monad.Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
open import Cat.Category.NaturalTransformation ℂ ℂ
|
||||
using (NaturalTransformation ; Transformation ; Natural)
|
||||
|
||||
private
|
||||
ℓ = ℓa ⊔ ℓb
|
||||
module ℂ = Category ℂ
|
||||
open ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_)
|
||||
open ℂ using (Arrow ; identity ; Object ; _<<<_ ; _>>>_)
|
||||
|
||||
-- | Data for a monad.
|
||||
--
|
||||
|
|
@ -32,7 +35,7 @@ record RawMonad : Set ℓ where
|
|||
--
|
||||
-- This should perhaps be defined in a "Klesli-version" of functors as well?
|
||||
fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ omap A , omap B ]
|
||||
fmap f = bind (pure ∘ f)
|
||||
fmap f = bind (pure <<< f)
|
||||
|
||||
-- | Composition of monads aka. the kleisli-arrow.
|
||||
_>=>_ : {A B C : Object} → ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ]
|
||||
|
|
@ -40,7 +43,7 @@ record RawMonad : Set ℓ where
|
|||
|
||||
-- | Flattening nested monads.
|
||||
join : {A : Object} → ℂ [ omap (omap A) , omap A ]
|
||||
join = bind 𝟙
|
||||
join = bind identity
|
||||
|
||||
------------------
|
||||
-- * Monad laws --
|
||||
|
|
@ -48,26 +51,33 @@ record RawMonad : Set ℓ where
|
|||
|
||||
-- There may be better names than what I've chosen here.
|
||||
|
||||
-- `pure` is the neutral element for `bind`
|
||||
IsIdentity = {X : Object}
|
||||
→ bind pure ≡ 𝟙 {omap X}
|
||||
→ bind pure ≡ identity {omap X}
|
||||
-- pure is the left-identity for the kleisli arrow.
|
||||
IsNatural = {X Y : Object} (f : ℂ [ X , omap Y ])
|
||||
→ pure >>> (bind f) ≡ f
|
||||
IsDistributive = {X Y Z : Object} (g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ])
|
||||
→ pure >=> f ≡ f
|
||||
-- Composition interacts with bind in the following way.
|
||||
IsDistributive = {X Y Z : Object}
|
||||
(g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ])
|
||||
→ (bind f) >>> (bind g) ≡ bind (f >=> g)
|
||||
|
||||
RightIdentity = {A B : Object} {m : ℂ [ A , omap B ]}
|
||||
→ m >=> pure ≡ m
|
||||
|
||||
-- | Functor map fusion.
|
||||
--
|
||||
-- This is really a functor law. Should we have a kleisli-representation of
|
||||
-- functors as well and make them a super-class?
|
||||
Fusion = {X Y Z : Object} {g : ℂ [ Y , Z ]} {f : ℂ [ X , Y ]}
|
||||
→ fmap (g ∘ f) ≡ fmap g ∘ fmap f
|
||||
→ fmap (g <<< f) ≡ fmap g <<< fmap f
|
||||
|
||||
-- In the ("foreign") formulation of a monad `IsNatural`'s analogue here would be:
|
||||
IsNaturalForeign : Set _
|
||||
IsNaturalForeign = {X : Object} → join {X} ∘ fmap join ≡ join ∘ join
|
||||
IsNaturalForeign = {X : Object} → join {X} <<< fmap join ≡ join <<< join
|
||||
|
||||
IsInverse : Set _
|
||||
IsInverse = {X : Object} → join {X} ∘ pure ≡ 𝟙 × join {X} ∘ fmap pure ≡ 𝟙
|
||||
IsInverse = {X : Object} → join {X} <<< pure ≡ identity × join {X} <<< fmap pure ≡ identity
|
||||
|
||||
record IsMonad (raw : RawMonad) : Set ℓ where
|
||||
open RawMonad raw public
|
||||
|
|
@ -79,18 +89,21 @@ record IsMonad (raw : RawMonad) : Set ℓ where
|
|||
-- | Map fusion is admissable.
|
||||
fusion : Fusion
|
||||
fusion {g = g} {f} = begin
|
||||
fmap (g ∘ f) ≡⟨⟩
|
||||
bind ((f >>> g) >>> pure) ≡⟨ cong bind ℂ.isAssociative ⟩
|
||||
bind (f >>> (g >>> pure)) ≡⟨ cong (λ φ → bind (f >>> φ)) (sym (isNatural _)) ⟩
|
||||
bind (f >>> (pure >>> (bind (g >>> pure)))) ≡⟨⟩
|
||||
fmap (g <<< f) ≡⟨⟩
|
||||
bind ((f >>> g) >>> pure) ≡⟨ cong bind ℂ.isAssociative ⟩
|
||||
bind (f >>> (g >>> pure))
|
||||
≡⟨ cong (λ φ → bind (f >>> φ)) (sym (isNatural _)) ⟩
|
||||
bind (f >>> (pure >>> (bind (g >>> pure))))
|
||||
≡⟨⟩
|
||||
bind (f >>> (pure >>> fmap g)) ≡⟨⟩
|
||||
bind ((fmap g ∘ pure) ∘ f) ≡⟨ cong bind (sym ℂ.isAssociative) ⟩
|
||||
bind (fmap g ∘ (pure ∘ f)) ≡⟨ sym distrib ⟩
|
||||
bind (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩
|
||||
fmap g ∘ fmap f ∎
|
||||
bind ((fmap g <<< pure) <<< f) ≡⟨ cong bind (sym ℂ.isAssociative) ⟩
|
||||
bind (fmap g <<< (pure <<< f)) ≡⟨ sym distrib ⟩
|
||||
bind (pure <<< g) <<< bind (pure <<< f)
|
||||
≡⟨⟩
|
||||
fmap g <<< fmap f ∎
|
||||
where
|
||||
distrib : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f))
|
||||
distrib = isDistributive (pure ∘ g) (pure ∘ f)
|
||||
distrib : fmap g <<< fmap f ≡ bind (fmap g <<< (pure <<< f))
|
||||
distrib = isDistributive (pure <<< g) (pure <<< f)
|
||||
|
||||
-- | This formulation gives rise to the following endo-functor.
|
||||
private
|
||||
|
|
@ -100,15 +113,15 @@ record IsMonad (raw : RawMonad) : Set ℓ where
|
|||
|
||||
isFunctorR : IsFunctor ℂ ℂ rawR
|
||||
IsFunctor.isIdentity isFunctorR = begin
|
||||
bind (pure ∘ 𝟙) ≡⟨ cong bind (ℂ.rightIdentity) ⟩
|
||||
bind pure ≡⟨ isIdentity ⟩
|
||||
𝟙 ∎
|
||||
bind (pure <<< identity) ≡⟨ cong bind (ℂ.rightIdentity) ⟩
|
||||
bind pure ≡⟨ isIdentity ⟩
|
||||
identity ∎
|
||||
|
||||
IsFunctor.isDistributive isFunctorR {f = f} {g} = begin
|
||||
bind (pure ∘ (g ∘ f)) ≡⟨⟩
|
||||
fmap (g ∘ f) ≡⟨ fusion ⟩
|
||||
fmap g ∘ fmap f ≡⟨⟩
|
||||
bind (pure ∘ g) ∘ bind (pure ∘ f) ∎
|
||||
bind (pure <<< (g <<< f)) ≡⟨⟩
|
||||
fmap (g <<< f) ≡⟨ fusion ⟩
|
||||
fmap g <<< fmap f ≡⟨⟩
|
||||
bind (pure <<< g) <<< bind (pure <<< f) ∎
|
||||
|
||||
-- FIXME Naming!
|
||||
R : EndoFunctor ℂ
|
||||
|
|
@ -116,10 +129,8 @@ record IsMonad (raw : RawMonad) : Set ℓ where
|
|||
Functor.isFunctor R = isFunctorR
|
||||
|
||||
private
|
||||
open NaturalTransformation ℂ ℂ
|
||||
|
||||
R⁰ : EndoFunctor ℂ
|
||||
R⁰ = F.identity
|
||||
R⁰ = Functors.identity
|
||||
R² : EndoFunctor ℂ
|
||||
R² = F[ R ∘ R ]
|
||||
module R = Functor R
|
||||
|
|
@ -129,66 +140,66 @@ record IsMonad (raw : RawMonad) : Set ℓ where
|
|||
pureT A = pure
|
||||
pureN : Natural R⁰ R pureT
|
||||
pureN {A} {B} f = begin
|
||||
pureT B ∘ R⁰.fmap f ≡⟨⟩
|
||||
pure ∘ f ≡⟨ sym (isNatural _) ⟩
|
||||
bind (pure ∘ f) ∘ pure ≡⟨⟩
|
||||
fmap f ∘ pure ≡⟨⟩
|
||||
R.fmap f ∘ pureT A ∎
|
||||
pureT B <<< R⁰.fmap f ≡⟨⟩
|
||||
pure <<< f ≡⟨ sym (isNatural _) ⟩
|
||||
bind (pure <<< f) <<< pure ≡⟨⟩
|
||||
fmap f <<< pure ≡⟨⟩
|
||||
R.fmap f <<< pureT A ∎
|
||||
joinT : Transformation R² R
|
||||
joinT C = join
|
||||
joinN : Natural R² R joinT
|
||||
joinN f = begin
|
||||
join ∘ R².fmap f ≡⟨⟩
|
||||
bind 𝟙 ∘ R².fmap f ≡⟨⟩
|
||||
R².fmap f >>> bind 𝟙 ≡⟨⟩
|
||||
fmap (fmap f) >>> bind 𝟙 ≡⟨⟩
|
||||
fmap (bind (f >>> pure)) >>> bind 𝟙 ≡⟨⟩
|
||||
bind (bind (f >>> pure) >>> pure) >>> bind 𝟙
|
||||
join <<< R².fmap f ≡⟨⟩
|
||||
bind identity <<< R².fmap f ≡⟨⟩
|
||||
R².fmap f >>> bind identity ≡⟨⟩
|
||||
fmap (fmap f) >>> bind identity ≡⟨⟩
|
||||
fmap (bind (f >>> pure)) >>> bind identity ≡⟨⟩
|
||||
bind (bind (f >>> pure) >>> pure) >>> bind identity
|
||||
≡⟨ isDistributive _ _ ⟩
|
||||
bind ((bind (f >>> pure) >>> pure) >=> 𝟙)
|
||||
bind ((bind (f >>> pure) >>> pure) >=> identity)
|
||||
≡⟨⟩
|
||||
bind ((bind (f >>> pure) >>> pure) >>> bind 𝟙)
|
||||
bind ((bind (f >>> pure) >>> pure) >>> bind identity)
|
||||
≡⟨ cong bind ℂ.isAssociative ⟩
|
||||
bind (bind (f >>> pure) >>> (pure >>> bind 𝟙))
|
||||
bind (bind (f >>> pure) >>> (pure >>> bind identity))
|
||||
≡⟨ cong (λ φ → bind (bind (f >>> pure) >>> φ)) (isNatural _) ⟩
|
||||
bind (bind (f >>> pure) >>> 𝟙)
|
||||
bind (bind (f >>> pure) >>> identity)
|
||||
≡⟨ cong bind ℂ.leftIdentity ⟩
|
||||
bind (bind (f >>> pure))
|
||||
≡⟨ cong bind (sym ℂ.rightIdentity) ⟩
|
||||
bind (𝟙 >>> bind (f >>> pure)) ≡⟨⟩
|
||||
bind (𝟙 >=> (f >>> pure))
|
||||
bind (identity >>> bind (f >>> pure)) ≡⟨⟩
|
||||
bind (identity >=> (f >>> pure))
|
||||
≡⟨ sym (isDistributive _ _) ⟩
|
||||
bind 𝟙 >>> bind (f >>> pure) ≡⟨⟩
|
||||
bind 𝟙 >>> fmap f ≡⟨⟩
|
||||
bind 𝟙 >>> R.fmap f ≡⟨⟩
|
||||
R.fmap f ∘ bind 𝟙 ≡⟨⟩
|
||||
R.fmap f ∘ join ∎
|
||||
bind identity >>> bind (f >>> pure) ≡⟨⟩
|
||||
bind identity >>> fmap f ≡⟨⟩
|
||||
bind identity >>> R.fmap f ≡⟨⟩
|
||||
R.fmap f <<< bind identity ≡⟨⟩
|
||||
R.fmap f <<< join ∎
|
||||
|
||||
pureNT : NaturalTransformation R⁰ R
|
||||
proj₁ pureNT = pureT
|
||||
proj₂ pureNT = pureN
|
||||
fst pureNT = pureT
|
||||
snd pureNT = pureN
|
||||
|
||||
joinNT : NaturalTransformation R² R
|
||||
proj₁ joinNT = joinT
|
||||
proj₂ joinNT = joinN
|
||||
fst joinNT = joinT
|
||||
snd joinNT = joinN
|
||||
|
||||
isNaturalForeign : IsNaturalForeign
|
||||
isNaturalForeign = begin
|
||||
fmap join >>> join ≡⟨⟩
|
||||
bind (join >>> pure) >>> bind 𝟙
|
||||
bind (join >>> pure) >>> bind identity
|
||||
≡⟨ isDistributive _ _ ⟩
|
||||
bind ((join >>> pure) >>> bind 𝟙)
|
||||
bind ((join >>> pure) >>> bind identity)
|
||||
≡⟨ cong bind ℂ.isAssociative ⟩
|
||||
bind (join >>> (pure >>> bind 𝟙))
|
||||
bind (join >>> (pure >>> bind identity))
|
||||
≡⟨ cong (λ φ → bind (join >>> φ)) (isNatural _) ⟩
|
||||
bind (join >>> 𝟙)
|
||||
bind (join >>> identity)
|
||||
≡⟨ cong bind ℂ.leftIdentity ⟩
|
||||
bind join ≡⟨⟩
|
||||
bind (bind 𝟙)
|
||||
bind (bind identity)
|
||||
≡⟨ cong bind (sym ℂ.rightIdentity) ⟩
|
||||
bind (𝟙 >>> bind 𝟙) ≡⟨⟩
|
||||
bind (𝟙 >=> 𝟙) ≡⟨ sym (isDistributive _ _) ⟩
|
||||
bind 𝟙 >>> bind 𝟙 ≡⟨⟩
|
||||
bind (identity >>> bind identity) ≡⟨⟩
|
||||
bind (identity >=> identity) ≡⟨ sym (isDistributive _ _) ⟩
|
||||
bind identity >>> bind identity ≡⟨⟩
|
||||
join >>> join ∎
|
||||
|
||||
isInverse : IsInverse
|
||||
|
|
@ -196,23 +207,31 @@ record IsMonad (raw : RawMonad) : Set ℓ where
|
|||
where
|
||||
inv-l = begin
|
||||
pure >>> join ≡⟨⟩
|
||||
pure >>> bind 𝟙 ≡⟨ isNatural _ ⟩
|
||||
𝟙 ∎
|
||||
pure >>> bind identity ≡⟨ isNatural _ ⟩
|
||||
identity ∎
|
||||
inv-r = begin
|
||||
fmap pure >>> join ≡⟨⟩
|
||||
bind (pure >>> pure) >>> bind 𝟙
|
||||
bind (pure >>> pure) >>> bind identity
|
||||
≡⟨ isDistributive _ _ ⟩
|
||||
bind ((pure >>> pure) >=> 𝟙) ≡⟨⟩
|
||||
bind ((pure >>> pure) >>> bind 𝟙)
|
||||
bind ((pure >>> pure) >=> identity) ≡⟨⟩
|
||||
bind ((pure >>> pure) >>> bind identity)
|
||||
≡⟨ cong bind ℂ.isAssociative ⟩
|
||||
bind (pure >>> (pure >>> bind 𝟙))
|
||||
bind (pure >>> (pure >>> bind identity))
|
||||
≡⟨ cong (λ φ → bind (pure >>> φ)) (isNatural _) ⟩
|
||||
bind (pure >>> 𝟙)
|
||||
bind (pure >>> identity)
|
||||
≡⟨ cong bind ℂ.leftIdentity ⟩
|
||||
bind pure ≡⟨ isIdentity ⟩
|
||||
𝟙 ∎
|
||||
identity ∎
|
||||
|
||||
rightIdentity : RightIdentity
|
||||
rightIdentity {m = m} = begin
|
||||
m >=> pure ≡⟨⟩
|
||||
m >>> bind pure ≡⟨ cong (m >>>_) isIdentity ⟩
|
||||
m >>> identity ≡⟨ ℂ.leftIdentity ⟩
|
||||
m ∎
|
||||
|
||||
record Monad : Set ℓ where
|
||||
no-eta-equality
|
||||
field
|
||||
raw : RawMonad
|
||||
isMonad : IsMonad raw
|
||||
|
|
@ -247,3 +266,82 @@ module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where
|
|||
Monad≡ : m ≡ n
|
||||
Monad.raw (Monad≡ i) = eq i
|
||||
Monad.isMonad (Monad≡ i) = eqIsMonad i
|
||||
|
||||
module _ where
|
||||
private
|
||||
module _ (x y : RawMonad) (p q : x ≡ y) (a b : p ≡ q) where
|
||||
eq0-helper : isGrpd (Object → Object)
|
||||
eq0-helper = grpdPi (λ a → ℂ.groupoidObject)
|
||||
|
||||
eq0 : cong (cong RawMonad.omap) a ≡ cong (cong RawMonad.omap) b
|
||||
eq0 = eq0-helper
|
||||
(RawMonad.omap x) (RawMonad.omap y)
|
||||
(cong RawMonad.omap p) (cong RawMonad.omap q)
|
||||
(cong (cong RawMonad.omap) a) (cong (cong RawMonad.omap) b)
|
||||
|
||||
eq1-helper : (omap : Object → Object) → isGrpd ({X : Object} → ℂ [ X , omap X ])
|
||||
eq1-helper f = grpdPiImpl (setGrpd ℂ.arrowsAreSets)
|
||||
|
||||
postulate
|
||||
eq1 : PathP (λ i → PathP
|
||||
(λ j →
|
||||
PathP (λ k → {X : Object} → ℂ [ X , eq0 i j k X ])
|
||||
(RawMonad.pure x) (RawMonad.pure y))
|
||||
(λ i → RawMonad.pure (p i)) (λ i → RawMonad.pure (q i)))
|
||||
(cong-d (cong-d RawMonad.pure) a) (cong-d (cong-d RawMonad.pure) b)
|
||||
|
||||
|
||||
RawMonad' : Set _
|
||||
RawMonad' = Σ (Object → Object) (λ omap
|
||||
→ ({X : Object} → ℂ [ X , omap X ])
|
||||
× ({X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ])
|
||||
)
|
||||
grpdRawMonad' : isGrpd RawMonad'
|
||||
grpdRawMonad' = grpdSig (grpdPi (λ _ → ℂ.groupoidObject)) λ _ → grpdSig (grpdPiImpl (setGrpd ℂ.arrowsAreSets)) (λ _ → grpdPiImpl (grpdPiImpl (grpdPi (λ _ → setGrpd ℂ.arrowsAreSets))))
|
||||
toRawMonad : RawMonad' → RawMonad
|
||||
RawMonad.omap (toRawMonad (a , b , c)) = a
|
||||
RawMonad.pure (toRawMonad (a , b , c)) = b
|
||||
RawMonad.bind (toRawMonad (a , b , c)) = c
|
||||
|
||||
IsMonad' : RawMonad' → Set _
|
||||
IsMonad' raw = M.IsIdentity × M.IsNatural × M.IsDistributive
|
||||
where
|
||||
module M = RawMonad (toRawMonad raw)
|
||||
|
||||
grpdIsMonad' : (m : RawMonad') → isGrpd (IsMonad' m)
|
||||
grpdIsMonad' m = grpdSig (propGrpd (propIsIdentity (toRawMonad m)))
|
||||
λ _ → grpdSig (propGrpd (propIsNatural (toRawMonad m)))
|
||||
λ _ → propGrpd (propIsDistributive (toRawMonad m))
|
||||
|
||||
Monad' = Σ RawMonad' IsMonad'
|
||||
grpdMonad' = grpdSig grpdRawMonad' grpdIsMonad'
|
||||
|
||||
toMonad : Monad' → Monad
|
||||
Monad.raw (toMonad x) = toRawMonad (fst x)
|
||||
isIdentity (Monad.isMonad (toMonad x)) = fst (snd x)
|
||||
isNatural (Monad.isMonad (toMonad x)) = fst (snd (snd x))
|
||||
isDistributive (Monad.isMonad (toMonad x)) = snd (snd (snd x))
|
||||
|
||||
fromMonad : Monad → Monad'
|
||||
fromMonad m = (M.omap , M.pure , M.bind)
|
||||
, M.isIdentity , M.isNatural , M.isDistributive
|
||||
where
|
||||
module M = Monad m
|
||||
|
||||
e : Monad' ≃ Monad
|
||||
e = fromIsomorphism _ _ (toMonad , fromMonad , (funExt λ _ → refl) , funExt eta-refl)
|
||||
where
|
||||
-- Monads don't have eta-equality
|
||||
eta-refl : (x : Monad) → toMonad (fromMonad x) ≡ x
|
||||
eta-refl =
|
||||
(λ x → λ
|
||||
{ i .Monad.raw → Monad.raw x
|
||||
; i .Monad.isMonad → Monad.isMonad x}
|
||||
)
|
||||
|
||||
grpdMonad : isGrpd Monad
|
||||
grpdMonad = equivPreservesNType
|
||||
{n = (S (S (S ⟨-2⟩)))}
|
||||
e grpdMonad'
|
||||
where
|
||||
open import Cubical.NType
|
||||
|
|
|
|||
|
|
@ -1,14 +1,13 @@
|
|||
{---
|
||||
Monoidal formulation of monads
|
||||
---}
|
||||
{-# OPTIONS --cubical --allow-unsolved-metas #-}
|
||||
{-# OPTIONS --cubical #-}
|
||||
open import Agda.Primitive
|
||||
|
||||
open import Cat.Prelude
|
||||
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor as F
|
||||
open import Cat.Category.NaturalTransformation
|
||||
open import Cat.Categories.Fun
|
||||
|
||||
module Cat.Category.Monad.Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
|
|
@ -17,43 +16,55 @@ module Cat.Category.Monad.Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb
|
|||
private
|
||||
ℓ = ℓa ⊔ ℓb
|
||||
|
||||
open Category ℂ using (Object ; Arrow ; 𝟙 ; _∘_)
|
||||
open NaturalTransformation ℂ ℂ
|
||||
open Category ℂ using (Object ; Arrow ; identity ; _<<<_)
|
||||
open import Cat.Category.NaturalTransformation ℂ ℂ
|
||||
using (NaturalTransformation ; Transformation ; Natural ; NaturalTransformation≡)
|
||||
|
||||
record RawMonad : Set ℓ where
|
||||
field
|
||||
R : EndoFunctor ℂ
|
||||
pureNT : NaturalTransformation F.identity R
|
||||
pureNT : NaturalTransformation Functors.identity R
|
||||
joinNT : NaturalTransformation F[ R ∘ R ] R
|
||||
|
||||
Romap = Functor.omap R
|
||||
fmap = Functor.fmap R
|
||||
|
||||
-- Note that `pureT` and `joinT` differs from their definition in the
|
||||
-- kleisli formulation only by having an explicit parameter.
|
||||
pureT : Transformation F.identity R
|
||||
pureT = proj₁ pureNT
|
||||
pureN : Natural F.identity R pureT
|
||||
pureN = proj₂ pureNT
|
||||
pureT : Transformation Functors.identity R
|
||||
pureT = fst pureNT
|
||||
|
||||
pure : {X : Object} → ℂ [ X , Romap X ]
|
||||
pure = pureT _
|
||||
|
||||
pureN : Natural Functors.identity R pureT
|
||||
pureN = snd pureNT
|
||||
|
||||
joinT : Transformation F[ R ∘ R ] R
|
||||
joinT = proj₁ joinNT
|
||||
joinT = fst joinNT
|
||||
join : {X : Object} → ℂ [ Romap (Romap X) , Romap X ]
|
||||
join = joinT _
|
||||
joinN : Natural F[ R ∘ R ] R joinT
|
||||
joinN = proj₂ joinNT
|
||||
|
||||
Romap = Functor.omap R
|
||||
Rfmap = Functor.fmap R
|
||||
joinN = snd joinNT
|
||||
|
||||
bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ]
|
||||
bind {X} {Y} f = joinT Y ∘ Rfmap f
|
||||
bind {X} {Y} f = join <<< fmap f
|
||||
|
||||
IsAssociative : Set _
|
||||
IsAssociative = {X : Object}
|
||||
→ joinT X ∘ Rfmap (joinT X) ≡ joinT X ∘ joinT (Romap X)
|
||||
-- R and join commute
|
||||
→ joinT X <<< fmap join ≡ join <<< join
|
||||
IsInverse : Set _
|
||||
IsInverse = {X : Object}
|
||||
→ joinT X ∘ pureT (Romap X) ≡ 𝟙
|
||||
× joinT X ∘ Rfmap (pureT X) ≡ 𝟙
|
||||
IsNatural = ∀ {X Y} f → joinT Y ∘ Rfmap f ∘ pureT X ≡ f
|
||||
-- Talks about R's action on objects
|
||||
→ join <<< pure ≡ identity {Romap X}
|
||||
-- Talks about R's action on arrows
|
||||
× join <<< fmap pure ≡ identity {Romap X}
|
||||
IsNatural = ∀ {X Y} (f : Arrow X (Romap Y))
|
||||
→ join <<< fmap f <<< pure ≡ f
|
||||
IsDistributive = ∀ {X Y Z} (g : Arrow Y (Romap Z)) (f : Arrow X (Romap Y))
|
||||
→ joinT Z ∘ Rfmap g ∘ (joinT Y ∘ Rfmap f)
|
||||
≡ joinT Z ∘ Rfmap (joinT Z ∘ Rfmap g ∘ f)
|
||||
→ join <<< fmap g <<< (join <<< fmap f)
|
||||
≡ join <<< fmap (join <<< fmap g <<< f)
|
||||
|
||||
record IsMonad (raw : RawMonad) : Set ℓ where
|
||||
open RawMonad raw public
|
||||
|
|
@ -67,51 +78,51 @@ record IsMonad (raw : RawMonad) : Set ℓ where
|
|||
|
||||
isNatural : IsNatural
|
||||
isNatural {X} {Y} f = begin
|
||||
joinT Y ∘ R.fmap f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩
|
||||
joinT Y ∘ (R.fmap f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩
|
||||
joinT Y ∘ (pureT (R.omap Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩
|
||||
joinT Y ∘ pureT (R.omap Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩
|
||||
𝟙 ∘ f ≡⟨ ℂ.leftIdentity ⟩
|
||||
f ∎
|
||||
join <<< fmap f <<< pure ≡⟨ sym ℂ.isAssociative ⟩
|
||||
join <<< (fmap f <<< pure) ≡⟨ cong (λ φ → join <<< φ) (sym (pureN f)) ⟩
|
||||
join <<< (pure <<< f) ≡⟨ ℂ.isAssociative ⟩
|
||||
join <<< pure <<< f ≡⟨ cong (λ φ → φ <<< f) (fst isInverse) ⟩
|
||||
identity <<< f ≡⟨ ℂ.leftIdentity ⟩
|
||||
f ∎
|
||||
|
||||
isDistributive : IsDistributive
|
||||
isDistributive {X} {Y} {Z} g f = sym aux
|
||||
isDistributive {X} {Y} {Z} g f = begin
|
||||
join <<< fmap g <<< (join <<< fmap f)
|
||||
≡⟨ Category.isAssociative ℂ ⟩
|
||||
join <<< fmap g <<< join <<< fmap f
|
||||
≡⟨ cong (_<<< fmap f) (sym ℂ.isAssociative) ⟩
|
||||
(join <<< (fmap g <<< join)) <<< fmap f
|
||||
≡⟨ cong (λ φ → φ <<< fmap f) (cong (_<<<_ join) (sym (joinN g))) ⟩
|
||||
(join <<< (join <<< R².fmap g)) <<< fmap f
|
||||
≡⟨ cong (_<<< fmap f) ℂ.isAssociative ⟩
|
||||
((join <<< join) <<< R².fmap g) <<< fmap f
|
||||
≡⟨⟩
|
||||
join <<< join <<< R².fmap g <<< fmap f
|
||||
≡⟨ sym ℂ.isAssociative ⟩
|
||||
(join <<< join) <<< (R².fmap g <<< fmap f)
|
||||
≡⟨ cong (λ φ → φ <<< (R².fmap g <<< fmap f)) (sym isAssociative) ⟩
|
||||
(join <<< fmap join) <<< (R².fmap g <<< fmap f)
|
||||
≡⟨ sym ℂ.isAssociative ⟩
|
||||
join <<< (fmap join <<< (R².fmap g <<< fmap f))
|
||||
≡⟨ cong (_<<<_ join) ℂ.isAssociative ⟩
|
||||
join <<< (fmap join <<< R².fmap g <<< fmap f)
|
||||
≡⟨⟩
|
||||
join <<< (fmap join <<< fmap (fmap g) <<< fmap f)
|
||||
≡⟨ cong (λ φ → join <<< φ) (sym distrib3) ⟩
|
||||
join <<< fmap (join <<< fmap g <<< f)
|
||||
∎
|
||||
where
|
||||
module R² = Functor F[ R ∘ R ]
|
||||
distrib3 : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B}
|
||||
→ R.fmap (a ∘ b ∘ c)
|
||||
≡ R.fmap a ∘ R.fmap b ∘ R.fmap c
|
||||
→ R.fmap (a <<< b <<< c)
|
||||
≡ R.fmap a <<< R.fmap b <<< R.fmap c
|
||||
distrib3 {a = a} {b} {c} = begin
|
||||
R.fmap (a ∘ b ∘ c) ≡⟨ R.isDistributive ⟩
|
||||
R.fmap (a ∘ b) ∘ R.fmap c ≡⟨ cong (_∘ _) R.isDistributive ⟩
|
||||
R.fmap a ∘ R.fmap b ∘ R.fmap c ∎
|
||||
aux = begin
|
||||
joinT Z ∘ R.fmap (joinT Z ∘ R.fmap g ∘ f)
|
||||
≡⟨ cong (λ φ → joinT Z ∘ φ) distrib3 ⟩
|
||||
joinT Z ∘ (R.fmap (joinT Z) ∘ R.fmap (R.fmap g) ∘ R.fmap f)
|
||||
≡⟨⟩
|
||||
joinT Z ∘ (R.fmap (joinT Z) ∘ R².fmap g ∘ R.fmap f)
|
||||
≡⟨ cong (_∘_ (joinT Z)) (sym ℂ.isAssociative) ⟩
|
||||
joinT Z ∘ (R.fmap (joinT Z) ∘ (R².fmap g ∘ R.fmap f))
|
||||
≡⟨ ℂ.isAssociative ⟩
|
||||
(joinT Z ∘ R.fmap (joinT Z)) ∘ (R².fmap g ∘ R.fmap f)
|
||||
≡⟨ cong (λ φ → φ ∘ (R².fmap g ∘ R.fmap f)) isAssociative ⟩
|
||||
(joinT Z ∘ joinT (R.omap Z)) ∘ (R².fmap g ∘ R.fmap f)
|
||||
≡⟨ ℂ.isAssociative ⟩
|
||||
joinT Z ∘ joinT (R.omap Z) ∘ R².fmap g ∘ R.fmap f
|
||||
≡⟨⟩
|
||||
((joinT Z ∘ joinT (R.omap Z)) ∘ R².fmap g) ∘ R.fmap f
|
||||
≡⟨ cong (_∘ R.fmap f) (sym ℂ.isAssociative) ⟩
|
||||
(joinT Z ∘ (joinT (R.omap Z) ∘ R².fmap g)) ∘ R.fmap f
|
||||
≡⟨ cong (λ φ → φ ∘ R.fmap f) (cong (_∘_ (joinT Z)) (joinN g)) ⟩
|
||||
(joinT Z ∘ (R.fmap g ∘ joinT Y)) ∘ R.fmap f
|
||||
≡⟨ cong (_∘ R.fmap f) ℂ.isAssociative ⟩
|
||||
joinT Z ∘ R.fmap g ∘ joinT Y ∘ R.fmap f
|
||||
≡⟨ sym (Category.isAssociative ℂ) ⟩
|
||||
joinT Z ∘ R.fmap g ∘ (joinT Y ∘ R.fmap f)
|
||||
∎
|
||||
R.fmap (a <<< b <<< c) ≡⟨ R.isDistributive ⟩
|
||||
R.fmap (a <<< b) <<< R.fmap c ≡⟨ cong (_<<< _) R.isDistributive ⟩
|
||||
R.fmap a <<< R.fmap b <<< R.fmap c ∎
|
||||
|
||||
record Monad : Set ℓ where
|
||||
no-eta-equality
|
||||
field
|
||||
raw : RawMonad
|
||||
isMonad : IsMonad raw
|
||||
|
|
@ -128,8 +139,8 @@ private
|
|||
where
|
||||
xX = x {X}
|
||||
yX = y {X}
|
||||
e1 = Category.arrowsAreSets ℂ _ _ (proj₁ xX) (proj₁ yX)
|
||||
e2 = Category.arrowsAreSets ℂ _ _ (proj₂ xX) (proj₂ yX)
|
||||
e1 = Category.arrowsAreSets ℂ _ _ (fst xX) (fst yX)
|
||||
e2 = Category.arrowsAreSets ℂ _ _ (snd xX) (snd yX)
|
||||
|
||||
open IsMonad
|
||||
propIsMonad : (raw : _) → isProp (IsMonad raw)
|
||||
|
|
|
|||
|
|
@ -1,30 +1,33 @@
|
|||
{-
|
||||
This module provides construction 2.3 in [voe]
|
||||
-}
|
||||
{-# OPTIONS --cubical --allow-unsolved-metas --caching #-}
|
||||
{-# OPTIONS --cubical #-}
|
||||
module Cat.Category.Monad.Voevodsky where
|
||||
|
||||
open import Cat.Prelude
|
||||
open import Function
|
||||
open import Cat.Equivalence
|
||||
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor as F
|
||||
open import Cat.Category.NaturalTransformation
|
||||
import Cat.Category.NaturalTransformation
|
||||
open import Cat.Category.Monad
|
||||
import Cat.Category.Monad.Monoidal as Monoidal
|
||||
import Cat.Category.Monad.Kleisli as Kleisli
|
||||
open import Cat.Categories.Fun
|
||||
open import Cat.Equivalence
|
||||
|
||||
module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
open Cat.Category.NaturalTransformation ℂ ℂ
|
||||
private
|
||||
ℓ = ℓa ⊔ ℓb
|
||||
module ℂ = Category ℂ
|
||||
open ℂ using (Object ; Arrow)
|
||||
open NaturalTransformation ℂ ℂ
|
||||
module M = Monoidal ℂ
|
||||
module K = Kleisli ℂ
|
||||
|
||||
module §2-3 (omap : Object → Object) (pure : {X : Object} → Arrow X (omap X)) where
|
||||
record §1 : Set ℓ where
|
||||
no-eta-equality
|
||||
open M
|
||||
|
||||
field
|
||||
|
|
@ -50,9 +53,9 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
pureT X = pure {X}
|
||||
|
||||
field
|
||||
pureN : Natural F.identity R pureT
|
||||
pureN : Natural Functors.identity R pureT
|
||||
|
||||
pureNT : NaturalTransformation F.identity R
|
||||
pureNT : NaturalTransformation Functors.identity R
|
||||
pureNT = pureT , pureN
|
||||
|
||||
joinT : (A : Object) → ℂ [ omap (omap A) , omap A ]
|
||||
|
|
@ -72,15 +75,14 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
}
|
||||
|
||||
field
|
||||
isMnd : IsMonad rawMnd
|
||||
isMonad : IsMonad rawMnd
|
||||
|
||||
toMonad : Monad
|
||||
toMonad = record
|
||||
{ raw = rawMnd
|
||||
; isMonad = isMnd
|
||||
}
|
||||
toMonad .Monad.raw = rawMnd
|
||||
toMonad .Monad.isMonad = isMonad
|
||||
|
||||
record §2 : Set ℓ where
|
||||
no-eta-equality
|
||||
open K
|
||||
|
||||
field
|
||||
|
|
@ -94,43 +96,33 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
}
|
||||
|
||||
field
|
||||
isMnd : IsMonad rawMnd
|
||||
isMonad : IsMonad rawMnd
|
||||
|
||||
toMonad : Monad
|
||||
toMonad = record
|
||||
{ raw = rawMnd
|
||||
; isMonad = isMnd
|
||||
}
|
||||
toMonad .Monad.raw = rawMnd
|
||||
toMonad .Monad.isMonad = isMonad
|
||||
|
||||
module _ (m : M.Monad) where
|
||||
open M.Monad m
|
||||
|
||||
§1-fromMonad : §2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X)
|
||||
§1-fromMonad .§2-3.§1.fmap = Functor.fmap R
|
||||
§1-fromMonad .§2-3.§1.RisFunctor = Functor.isFunctor R
|
||||
§1-fromMonad .§2-3.§1.pureN = pureN
|
||||
§1-fromMonad .§2-3.§1.join {X} = joinT X
|
||||
§1-fromMonad .§2-3.§1.joinN = joinN
|
||||
§1-fromMonad .§2-3.§1.isMonad = M.Monad.isMonad m
|
||||
|
||||
§1-fromMonad : (m : M.Monad) → §2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X)
|
||||
-- voe-2-3-1-fromMonad : (m : M.Monad) → voe.§2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X)
|
||||
§1-fromMonad m = record
|
||||
{ fmap = Functor.fmap R
|
||||
; RisFunctor = Functor.isFunctor R
|
||||
; pureN = pureN
|
||||
; join = λ {X} → joinT X
|
||||
; joinN = joinN
|
||||
; isMnd = M.Monad.isMonad m
|
||||
}
|
||||
where
|
||||
raw = M.Monad.raw m
|
||||
R = M.RawMonad.R raw
|
||||
pureT = M.RawMonad.pureT raw
|
||||
pureN = M.RawMonad.pureN raw
|
||||
joinT = M.RawMonad.joinT raw
|
||||
joinN = M.RawMonad.joinN raw
|
||||
|
||||
§2-fromMonad : (m : K.Monad) → §2-3.§2 (K.Monad.omap m) (K.Monad.pure m)
|
||||
§2-fromMonad m = record
|
||||
{ bind = K.Monad.bind m
|
||||
; isMnd = K.Monad.isMonad m
|
||||
}
|
||||
§2-fromMonad m .§2-3.§2.bind = K.Monad.bind m
|
||||
§2-fromMonad m .§2-3.§2.isMonad = K.Monad.isMonad m
|
||||
|
||||
-- | In the following we seek to transform the equivalence `Monoidal≃Kleisli`
|
||||
-- | to talk about voevodsky's construction.
|
||||
module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where
|
||||
private
|
||||
module E = AreInverses (Monoidal≅Kleisli ℂ .proj₂ .proj₂)
|
||||
module E = AreInverses {f = (fst (Monoidal≊Kleisli ℂ))} {fst (snd (Monoidal≊Kleisli ℂ))}(Monoidal≊Kleisli ℂ .snd .snd)
|
||||
|
||||
Monoidal→Kleisli : M.Monad → K.Monad
|
||||
Monoidal→Kleisli = E.obverse
|
||||
|
|
@ -138,10 +130,10 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
Kleisli→Monoidal : K.Monad → M.Monad
|
||||
Kleisli→Monoidal = E.reverse
|
||||
|
||||
ve-re : Kleisli→Monoidal ∘ Monoidal→Kleisli ≡ Function.id
|
||||
ve-re : Kleisli→Monoidal ∘ Monoidal→Kleisli ≡ idFun _
|
||||
ve-re = E.verso-recto
|
||||
|
||||
re-ve : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ Function.id
|
||||
re-ve : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ idFun _
|
||||
re-ve = E.recto-verso
|
||||
|
||||
forth : §2-3.§1 omap pure → §2-3.§2 omap pure
|
||||
|
|
@ -152,70 +144,103 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
|
||||
forthEq : ∀ m → (forth ∘ back) m ≡ m
|
||||
forthEq m = begin
|
||||
(forth ∘ back) m ≡⟨⟩
|
||||
-- In full gory detail:
|
||||
( §2-fromMonad
|
||||
∘ Monoidal→Kleisli
|
||||
∘ §2-3.§1.toMonad
|
||||
∘ §1-fromMonad
|
||||
∘ Kleisli→Monoidal
|
||||
∘ §2-3.§2.toMonad
|
||||
) m ≡⟨⟩ -- fromMonad and toMonad are inverses
|
||||
( §2-fromMonad
|
||||
∘ Monoidal→Kleisli
|
||||
∘ Kleisli→Monoidal
|
||||
∘ §2-3.§2.toMonad
|
||||
) m ≡⟨ cong (λ φ → φ m) t ⟩
|
||||
-- Monoidal→Kleisli and Kleisli→Monoidal are inverses
|
||||
-- I should be able to prove this using congruence and `lem` below.
|
||||
( §2-fromMonad
|
||||
∘ §2-3.§2.toMonad
|
||||
) m ≡⟨⟩
|
||||
( §2-fromMonad
|
||||
∘ §2-3.§2.toMonad
|
||||
) m ≡⟨⟩ -- fromMonad and toMonad are inverses
|
||||
m ∎
|
||||
§2-fromMonad
|
||||
(Monoidal→Kleisli
|
||||
(§2-3.§1.toMonad
|
||||
(§1-fromMonad (Kleisli→Monoidal (§2-3.§2.toMonad m)))))
|
||||
≡⟨ cong-d (§2-fromMonad ∘ Monoidal→Kleisli) (lemmaz (Kleisli→Monoidal (§2-3.§2.toMonad m))) ⟩
|
||||
§2-fromMonad
|
||||
((Monoidal→Kleisli ∘ Kleisli→Monoidal)
|
||||
(§2-3.§2.toMonad m))
|
||||
-- Below is the fully normalized goal and context with
|
||||
-- `funExt` made abstract.
|
||||
--
|
||||
-- Goal: PathP (λ _ → §2-3.§2 omap (λ {z} → pure))
|
||||
-- (§2-fromMonad
|
||||
-- (.Cat.Category.Monad.toKleisli ℂ
|
||||
-- (.Cat.Category.Monad.toMonoidal ℂ (§2-3.§2.toMonad m))))
|
||||
-- (§2-fromMonad (§2-3.§2.toMonad m))
|
||||
-- Have: PathP
|
||||
-- (λ i →
|
||||
-- §2-3.§2 K.IsMonad.omap
|
||||
-- (K.RawMonad.pure
|
||||
-- (K.Monad.raw
|
||||
-- (funExt (λ m₁ → K.Monad≡ (.Cat.Category.Monad.toKleisliRawEq ℂ m₁))
|
||||
-- i (§2-3.§2.toMonad m)))))
|
||||
-- (§2-fromMonad
|
||||
-- (.Cat.Category.Monad.toKleisli ℂ
|
||||
-- (.Cat.Category.Monad.toMonoidal ℂ (§2-3.§2.toMonad m))))
|
||||
-- (§2-fromMonad (§2-3.§2.toMonad m))
|
||||
≡⟨ ( cong-d {x = Monoidal→Kleisli ∘ Kleisli→Monoidal} {y = idFun K.Monad} (\ φ → §2-fromMonad (φ (§2-3.§2.toMonad m))) re-ve) ⟩
|
||||
(§2-fromMonad ∘ §2-3.§2.toMonad) m
|
||||
≡⟨ lemma ⟩
|
||||
m ∎
|
||||
where
|
||||
t' : ((Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ §2-3.§2.toMonad {omap} {pure})
|
||||
≡ §2-3.§2.toMonad
|
||||
cong-d : ∀ {ℓ} {A : Set ℓ} {ℓ'} {B : A → Set ℓ'} {x y : A}
|
||||
→ (f : (x : A) → B x) → (eq : x ≡ y) → PathP (\ i → B (eq i)) (f x) (f y)
|
||||
cong-d f p = λ i → f (p i)
|
||||
t' = cong (\ φ → φ ∘ §2-3.§2.toMonad) re-ve
|
||||
t : (§2-fromMonad ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ §2-3.§2.toMonad {omap} {pure})
|
||||
≡ (§2-fromMonad ∘ §2-3.§2.toMonad)
|
||||
t = cong-d (\ f → §2-fromMonad ∘ f) t'
|
||||
u : (§2-fromMonad ∘ (Monoidal→Kleisli ∘ Kleisli→Monoidal) ∘ §2-3.§2.toMonad) m
|
||||
≡ (§2-fromMonad ∘ §2-3.§2.toMonad) m
|
||||
u = cong (\ φ → φ m) t
|
||||
lemma : (§2-fromMonad ∘ §2-3.§2.toMonad) m ≡ m
|
||||
§2-3.§2.bind (lemma i) = §2-3.§2.bind m
|
||||
§2-3.§2.isMonad (lemma i) = §2-3.§2.isMonad m
|
||||
lemmaz : ∀ m → §2-3.§1.toMonad (§1-fromMonad m) ≡ m
|
||||
M.Monad.raw (lemmaz m i) = M.Monad.raw m
|
||||
M.Monad.isMonad (lemmaz m i) = M.Monad.isMonad m
|
||||
|
||||
backEq : ∀ m → (back ∘ forth) m ≡ m
|
||||
backEq m = begin
|
||||
(back ∘ forth) m ≡⟨⟩
|
||||
( §1-fromMonad
|
||||
∘ Kleisli→Monoidal
|
||||
∘ §2-3.§2.toMonad
|
||||
∘ §2-fromMonad
|
||||
∘ Monoidal→Kleisli
|
||||
∘ §2-3.§1.toMonad
|
||||
) m ≡⟨⟩ -- fromMonad and toMonad are inverses
|
||||
( §1-fromMonad
|
||||
∘ Kleisli→Monoidal
|
||||
∘ Monoidal→Kleisli
|
||||
∘ §2-3.§1.toMonad
|
||||
) m ≡⟨ cong (λ φ → φ m) t ⟩ -- Monoidal→Kleisli and Kleisli→Monoidal are inverses
|
||||
( §1-fromMonad
|
||||
∘ §2-3.§1.toMonad
|
||||
) m ≡⟨⟩ -- fromMonad and toMonad are inverses
|
||||
§1-fromMonad
|
||||
(Kleisli→Monoidal
|
||||
(§2-3.§2.toMonad
|
||||
(§2-fromMonad (Monoidal→Kleisli (§2-3.§1.toMonad m)))))
|
||||
≡⟨ cong-d (§1-fromMonad ∘ Kleisli→Monoidal) (lemma (Monoidal→Kleisli (§2-3.§1.toMonad m))) ⟩
|
||||
§1-fromMonad
|
||||
((Kleisli→Monoidal ∘ Monoidal→Kleisli)
|
||||
(§2-3.§1.toMonad m))
|
||||
-- Below is the fully normalized `agda2-goal-and-context`
|
||||
-- with `funExt` made abstract.
|
||||
--
|
||||
-- Goal: PathP (λ _ → §2-3.§1 omap (λ {X} → pure))
|
||||
-- (§1-fromMonad
|
||||
-- (.Cat.Category.Monad.toMonoidal ℂ
|
||||
-- (.Cat.Category.Monad.toKleisli ℂ (§2-3.§1.toMonad m))))
|
||||
-- (§1-fromMonad (§2-3.§1.toMonad m))
|
||||
-- Have: PathP
|
||||
-- (λ i →
|
||||
-- §2-3.§1
|
||||
-- (RawFunctor.omap
|
||||
-- (Functor.raw
|
||||
-- (M.RawMonad.R
|
||||
-- (M.Monad.raw
|
||||
-- (funExt
|
||||
-- (λ m₁ → M.Monad≡ (.Cat.Category.Monad.toMonoidalRawEq ℂ m₁)) i
|
||||
-- (§2-3.§1.toMonad m))))))
|
||||
-- (λ {X} →
|
||||
-- fst
|
||||
-- (M.RawMonad.pureNT
|
||||
-- (M.Monad.raw
|
||||
-- (funExt
|
||||
-- (λ m₁ → M.Monad≡ (.Cat.Category.Monad.toMonoidalRawEq ℂ m₁)) i
|
||||
-- (§2-3.§1.toMonad m))))
|
||||
-- X))
|
||||
-- (§1-fromMonad
|
||||
-- (.Cat.Category.Monad.toMonoidal ℂ
|
||||
-- (.Cat.Category.Monad.toKleisli ℂ (§2-3.§1.toMonad m))))
|
||||
-- (§1-fromMonad (§2-3.§1.toMonad m))
|
||||
≡⟨ (cong-d (\ φ → §1-fromMonad (φ (§2-3.§1.toMonad m))) ve-re) ⟩
|
||||
§1-fromMonad (§2-3.§1.toMonad m)
|
||||
≡⟨ lemmaz ⟩
|
||||
m ∎
|
||||
where
|
||||
t : §1-fromMonad ∘ Kleisli→Monoidal ∘ Monoidal→Kleisli ∘ §2-3.§1.toMonad
|
||||
≡ §1-fromMonad ∘ §2-3.§1.toMonad
|
||||
-- Why does `re-ve` not satisfy this goal?
|
||||
t i m = §1-fromMonad (ve-re i (§2-3.§1.toMonad m))
|
||||
|
||||
voe-isEquiv : isEquiv (§2-3.§1 omap pure) (§2-3.§2 omap pure) forth
|
||||
voe-isEquiv = gradLemma forth back forthEq backEq
|
||||
where
|
||||
lemmaz : §1-fromMonad (§2-3.§1.toMonad m) ≡ m
|
||||
§2-3.§1.fmap (lemmaz i) = §2-3.§1.fmap m
|
||||
§2-3.§1.join (lemmaz i) = §2-3.§1.join m
|
||||
§2-3.§1.RisFunctor (lemmaz i) = §2-3.§1.RisFunctor m
|
||||
§2-3.§1.pureN (lemmaz i) = §2-3.§1.pureN m
|
||||
§2-3.§1.joinN (lemmaz i) = §2-3.§1.joinN m
|
||||
§2-3.§1.isMonad (lemmaz i) = §2-3.§1.isMonad m
|
||||
lemma : ∀ m → §2-3.§2.toMonad (§2-fromMonad m) ≡ m
|
||||
K.Monad.raw (lemma m i) = K.Monad.raw m
|
||||
K.Monad.isMonad (lemma m i) = K.Monad.isMonad m
|
||||
|
||||
equiv-2-3 : §2-3.§1 omap pure ≃ §2-3.§2 omap pure
|
||||
equiv-2-3 = forth , voe-isEquiv
|
||||
equiv-2-3 = fromIsomorphism _ _
|
||||
( forth , back
|
||||
, funExt backEq , funExt forthEq
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# OPTIONS --allow-unsolved-metas #-}
|
||||
module Cat.Category.Monoid where
|
||||
|
||||
open import Agda.Primitive
|
||||
|
|
@ -6,9 +7,10 @@ open import Cat.Category
|
|||
open import Cat.Category.Product
|
||||
open import Cat.Category.Functor
|
||||
import Cat.Categories.Cat as Cat
|
||||
open import Cat.Prelude hiding (_×_ ; empty)
|
||||
|
||||
-- TODO: Incorrect!
|
||||
module _ (ℓa ℓb : Level) where
|
||||
module _ {ℓa ℓb : Level} where
|
||||
private
|
||||
ℓ = lsuc (ℓa ⊔ ℓb)
|
||||
|
||||
|
|
@ -21,30 +23,34 @@ module _ (ℓa ℓb : Level) where
|
|||
_×_ : ∀ {ℓa ℓb} → Category ℓa ℓb → Category ℓa ℓb → Category ℓa ℓb
|
||||
ℂ × 𝔻 = Cat.CatProduct.object ℂ 𝔻
|
||||
|
||||
record RawMonoidalCategory : Set ℓ where
|
||||
record RawMonoidalCategory (ℂ : Category ℓa ℓb) : Set ℓ where
|
||||
open Category ℂ public hiding (IsAssociative)
|
||||
field
|
||||
category : Category ℓa ℓb
|
||||
open Category category public
|
||||
field
|
||||
{{hasProducts}} : HasProducts category
|
||||
empty : Object
|
||||
-- aka. tensor product, monoidal product.
|
||||
append : Functor (category × category) category
|
||||
open HasProducts hasProducts public
|
||||
append : Functor (ℂ × ℂ) ℂ
|
||||
|
||||
record MonoidalCategory : Set ℓ where
|
||||
module F = Functor append
|
||||
|
||||
_⊗_ = append
|
||||
mappend = F.fmap
|
||||
|
||||
IsAssociative : Set _
|
||||
IsAssociative = {A B : Object} → (f g h : Arrow A A) → mappend ({!mappend!} , {!mappend!}) ≡ mappend (f , mappend (g , h))
|
||||
|
||||
record MonoidalCategory (ℂ : Category ℓa ℓb) : Set ℓ where
|
||||
field
|
||||
raw : RawMonoidalCategory
|
||||
raw : RawMonoidalCategory ℂ
|
||||
open RawMonoidalCategory raw public
|
||||
|
||||
module _ {ℓa ℓb : Level} (ℂ : MonoidalCategory ℓa ℓb) where
|
||||
module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) {monoidal : MonoidalCategory ℂ} {hasProducts : HasProducts ℂ} where
|
||||
private
|
||||
ℓ = ℓa ⊔ ℓb
|
||||
|
||||
open MonoidalCategory ℂ public
|
||||
open MonoidalCategory monoidal public hiding (mappend)
|
||||
open HasProducts hasProducts
|
||||
|
||||
record Monoid : Set ℓ where
|
||||
record MonoidalObject (M : Object) : Set ℓ where
|
||||
field
|
||||
carrier : Object
|
||||
mempty : Arrow empty carrier
|
||||
mappend : Arrow (carrier × carrier) carrier
|
||||
mempty : Arrow empty M
|
||||
mappend : Arrow (M × M) M
|
||||
|
|
|
|||
|
|
@ -17,89 +17,88 @@
|
|||
-- Functions for manipulating the above:
|
||||
--
|
||||
-- * A composition operator.
|
||||
{-# OPTIONS --allow-unsolved-metas --cubical #-}
|
||||
module Cat.Category.NaturalTransformation where
|
||||
|
||||
{-# OPTIONS --cubical #-}
|
||||
open import Cat.Prelude
|
||||
|
||||
open import Data.Nat using (_≤_ ; z≤n ; s≤s)
|
||||
open import Data.Nat using (_≤′_ ; ≤′-refl ; ≤′-step)
|
||||
module Nat = Data.Nat
|
||||
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor hiding (identity)
|
||||
open import Cat.Wishlist
|
||||
open import Cat.Category.Functor
|
||||
|
||||
module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level}
|
||||
module Cat.Category.NaturalTransformation
|
||||
{ℓc ℓc' ℓd ℓd' : Level}
|
||||
(ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where
|
||||
|
||||
open Category using (Object ; 𝟙)
|
||||
open Category using (Object)
|
||||
private
|
||||
module ℂ = Category ℂ
|
||||
module 𝔻 = Category 𝔻
|
||||
|
||||
module _ (F G : Functor ℂ 𝔻) where
|
||||
private
|
||||
module ℂ = Category ℂ
|
||||
module 𝔻 = Category 𝔻
|
||||
module F = Functor F
|
||||
module G = Functor G
|
||||
-- What do you call a non-natural tranformation?
|
||||
Transformation : Set (ℓc ⊔ ℓd')
|
||||
Transformation = (C : Object ℂ) → 𝔻 [ F.omap C , G.omap C ]
|
||||
|
||||
module _ (F G : Functor ℂ 𝔻) where
|
||||
private
|
||||
module F = Functor F
|
||||
module G = Functor G
|
||||
-- What do you call a non-natural tranformation?
|
||||
Transformation : Set (ℓc ⊔ ℓd')
|
||||
Transformation = (C : Object ℂ) → 𝔻 [ F.omap C , G.omap C ]
|
||||
Natural : Transformation → Set (ℓc ⊔ (ℓc' ⊔ ℓd'))
|
||||
Natural θ
|
||||
= {A B : Object ℂ}
|
||||
→ (f : ℂ [ A , B ])
|
||||
→ 𝔻 [ θ B ∘ F.fmap f ] ≡ 𝔻 [ G.fmap f ∘ θ A ]
|
||||
|
||||
Natural : Transformation → Set (ℓc ⊔ (ℓc' ⊔ ℓd'))
|
||||
Natural θ
|
||||
= {A B : Object ℂ}
|
||||
→ (f : ℂ [ A , B ])
|
||||
→ 𝔻 [ θ B ∘ F.fmap f ] ≡ 𝔻 [ G.fmap f ∘ θ A ]
|
||||
NaturalTransformation : Set (ℓc ⊔ ℓc' ⊔ ℓd')
|
||||
NaturalTransformation = Σ Transformation Natural
|
||||
|
||||
NaturalTransformation : Set (ℓc ⊔ ℓc' ⊔ ℓd')
|
||||
NaturalTransformation = Σ Transformation Natural
|
||||
-- Think I need propPi and that arrows are sets
|
||||
propIsNatural : (θ : _) → isProp (Natural θ)
|
||||
propIsNatural θ x y i {A} {B} f = 𝔻.arrowsAreSets _ _ (x f) (y f) i
|
||||
|
||||
-- Think I need propPi and that arrows are sets
|
||||
propIsNatural : (θ : _) → isProp (Natural θ)
|
||||
propIsNatural θ x y i {A} {B} f = 𝔻.arrowsAreSets _ _ (x f) (y f) i
|
||||
NaturalTransformation≡ : {α β : NaturalTransformation}
|
||||
→ (eq₁ : α .fst ≡ β .fst)
|
||||
→ α ≡ β
|
||||
NaturalTransformation≡ eq = lemSig propIsNatural _ _ eq
|
||||
|
||||
NaturalTransformation≡ : {α β : NaturalTransformation}
|
||||
→ (eq₁ : α .proj₁ ≡ β .proj₁)
|
||||
→ α ≡ β
|
||||
NaturalTransformation≡ eq = lemSig propIsNatural _ _ eq
|
||||
identityTrans : (F : Functor ℂ 𝔻) → Transformation F F
|
||||
identityTrans F C = 𝔻.identity
|
||||
|
||||
identityTrans : (F : Functor ℂ 𝔻) → Transformation F F
|
||||
identityTrans F C = 𝟙 𝔻
|
||||
identityNatural : (F : Functor ℂ 𝔻) → Natural F F (identityTrans F)
|
||||
identityNatural F {A = A} {B = B} f = begin
|
||||
𝔻 [ identityTrans F B ∘ F→ f ] ≡⟨⟩
|
||||
𝔻 [ 𝔻.identity ∘ F→ f ] ≡⟨ 𝔻.leftIdentity ⟩
|
||||
F→ f ≡⟨ sym 𝔻.rightIdentity ⟩
|
||||
𝔻 [ F→ f ∘ 𝔻.identity ] ≡⟨⟩
|
||||
𝔻 [ F→ f ∘ identityTrans F A ] ∎
|
||||
where
|
||||
module F = Functor F
|
||||
F→ = F.fmap
|
||||
|
||||
identityNatural : (F : Functor ℂ 𝔻) → Natural F F (identityTrans F)
|
||||
identityNatural F {A = A} {B = B} f = begin
|
||||
𝔻 [ identityTrans F B ∘ F→ f ] ≡⟨⟩
|
||||
𝔻 [ 𝟙 𝔻 ∘ F→ f ] ≡⟨ 𝔻.leftIdentity ⟩
|
||||
F→ f ≡⟨ sym 𝔻.rightIdentity ⟩
|
||||
𝔻 [ F→ f ∘ 𝟙 𝔻 ] ≡⟨⟩
|
||||
𝔻 [ F→ f ∘ identityTrans F A ] ∎
|
||||
where
|
||||
module F = Functor F
|
||||
F→ = F.fmap
|
||||
identity : (F : Functor ℂ 𝔻) → NaturalTransformation F F
|
||||
identity F = identityTrans F , identityNatural F
|
||||
|
||||
identity : (F : Functor ℂ 𝔻) → NaturalTransformation F F
|
||||
identity F = identityTrans F , identityNatural F
|
||||
module _ {F G H : Functor ℂ 𝔻} where
|
||||
private
|
||||
module F = Functor F
|
||||
module G = Functor G
|
||||
module H = Functor H
|
||||
T[_∘_] : Transformation G H → Transformation F G → Transformation F H
|
||||
T[ θ ∘ η ] C = 𝔻 [ θ C ∘ η C ]
|
||||
|
||||
module _ {F G H : Functor ℂ 𝔻} where
|
||||
private
|
||||
module F = Functor F
|
||||
module G = Functor G
|
||||
module H = Functor H
|
||||
T[_∘_] : Transformation G H → Transformation F G → Transformation F H
|
||||
T[ θ ∘ η ] C = 𝔻 [ θ C ∘ η C ]
|
||||
|
||||
NT[_∘_] : NaturalTransformation G H → NaturalTransformation F G → NaturalTransformation F H
|
||||
proj₁ NT[ (θ , _) ∘ (η , _) ] = T[ θ ∘ η ]
|
||||
proj₂ NT[ (θ , θNat) ∘ (η , ηNat) ] {A} {B} f = begin
|
||||
𝔻 [ T[ θ ∘ η ] B ∘ F.fmap f ] ≡⟨⟩
|
||||
𝔻 [ 𝔻 [ θ B ∘ η B ] ∘ F.fmap f ] ≡⟨ sym 𝔻.isAssociative ⟩
|
||||
𝔻 [ θ B ∘ 𝔻 [ η B ∘ F.fmap f ] ] ≡⟨ cong (λ φ → 𝔻 [ θ B ∘ φ ]) (ηNat f) ⟩
|
||||
𝔻 [ θ B ∘ 𝔻 [ G.fmap f ∘ η A ] ] ≡⟨ 𝔻.isAssociative ⟩
|
||||
𝔻 [ 𝔻 [ θ B ∘ G.fmap f ] ∘ η A ] ≡⟨ cong (λ φ → 𝔻 [ φ ∘ η A ]) (θNat f) ⟩
|
||||
𝔻 [ 𝔻 [ H.fmap f ∘ θ A ] ∘ η A ] ≡⟨ sym 𝔻.isAssociative ⟩
|
||||
𝔻 [ H.fmap f ∘ 𝔻 [ θ A ∘ η A ] ] ≡⟨⟩
|
||||
𝔻 [ H.fmap f ∘ T[ θ ∘ η ] A ] ∎
|
||||
NT[_∘_] : NaturalTransformation G H → NaturalTransformation F G → NaturalTransformation F H
|
||||
fst NT[ (θ , _) ∘ (η , _) ] = T[ θ ∘ η ]
|
||||
snd NT[ (θ , θNat) ∘ (η , ηNat) ] {A} {B} f = begin
|
||||
𝔻 [ T[ θ ∘ η ] B ∘ F.fmap f ] ≡⟨⟩
|
||||
𝔻 [ 𝔻 [ θ B ∘ η B ] ∘ F.fmap f ] ≡⟨ sym 𝔻.isAssociative ⟩
|
||||
𝔻 [ θ B ∘ 𝔻 [ η B ∘ F.fmap f ] ] ≡⟨ cong (λ φ → 𝔻 [ θ B ∘ φ ]) (ηNat f) ⟩
|
||||
𝔻 [ θ B ∘ 𝔻 [ G.fmap f ∘ η A ] ] ≡⟨ 𝔻.isAssociative ⟩
|
||||
𝔻 [ 𝔻 [ θ B ∘ G.fmap f ] ∘ η A ] ≡⟨ cong (λ φ → 𝔻 [ φ ∘ η A ]) (θNat f) ⟩
|
||||
𝔻 [ 𝔻 [ H.fmap f ∘ θ A ] ∘ η A ] ≡⟨ sym 𝔻.isAssociative ⟩
|
||||
𝔻 [ H.fmap f ∘ 𝔻 [ θ A ∘ η A ] ] ≡⟨⟩
|
||||
𝔻 [ H.fmap f ∘ T[ θ ∘ η ] A ] ∎
|
||||
|
||||
module Properties where
|
||||
module _ {F G : Functor ℂ 𝔻} where
|
||||
transformationIsSet : isSet (Transformation F G)
|
||||
transformationIsSet _ _ p q i j C = 𝔻.arrowsAreSets _ _ (λ l → p l C) (λ l → q l C) i j
|
||||
|
|
@ -112,9 +111,37 @@ module NaturalTransformation {ℓc ℓc' ℓd ℓd' : Level}
|
|||
|
||||
naturalIsSet : (θ : Transformation F G) → isSet (Natural F G θ)
|
||||
naturalIsSet θ =
|
||||
ntypeCommulative
|
||||
(s≤s {n = Nat.suc Nat.zero} z≤n)
|
||||
ntypeCumulative {n = 1}
|
||||
(Data.Nat.≤′-step Data.Nat.≤′-refl)
|
||||
(naturalIsProp θ)
|
||||
|
||||
naturalTransformationIsSet : isSet (NaturalTransformation F G)
|
||||
naturalTransformationIsSet = sigPresSet transformationIsSet naturalIsSet
|
||||
|
||||
module _
|
||||
{F G H I : Functor ℂ 𝔻}
|
||||
{θ : NaturalTransformation F G}
|
||||
{η : NaturalTransformation G H}
|
||||
{ζ : NaturalTransformation H I} where
|
||||
-- isAssociative : NT[ ζ ∘ NT[ η ∘ θ ] ] ≡ NT[ NT[ ζ ∘ η ] ∘ θ ]
|
||||
isAssociative
|
||||
: NT[_∘_] {F} {H} {I} ζ (NT[_∘_] {F} {G} {H} η θ)
|
||||
≡ NT[_∘_] {F} {G} {I} (NT[_∘_] {G} {H} {I} ζ η) θ
|
||||
isAssociative
|
||||
= lemSig (naturalIsProp {F = F} {I}) _ _
|
||||
(funExt (λ _ → 𝔻.isAssociative))
|
||||
|
||||
module _ {F G : Functor ℂ 𝔻} {θNT : NaturalTransformation F G} where
|
||||
private
|
||||
propNat = naturalIsProp {F = F} {G}
|
||||
|
||||
rightIdentity : (NT[_∘_] {F} {F} {G} θNT (identity F)) ≡ θNT
|
||||
rightIdentity = lemSig propNat _ _ (funExt (λ _ → 𝔻.rightIdentity))
|
||||
|
||||
leftIdentity : (NT[_∘_] {F} {G} {G} (identity G) θNT) ≡ θNT
|
||||
leftIdentity = lemSig propNat _ _ (funExt (λ _ → 𝔻.leftIdentity))
|
||||
|
||||
isIdentity
|
||||
: (NT[_∘_] {F} {G} {G} (identity G) θNT) ≡ θNT
|
||||
× (NT[_∘_] {F} {F} {G} θNT (identity F)) ≡ θNT
|
||||
isIdentity = leftIdentity , rightIdentity
|
||||
|
|
|
|||
|
|
@ -1,35 +1,32 @@
|
|||
{-# OPTIONS --allow-unsolved-metas #-}
|
||||
{-# OPTIONS --cubical --caching #-}
|
||||
module Cat.Category.Product where
|
||||
|
||||
open import Cat.Prelude hiding (_×_ ; proj₁ ; proj₂)
|
||||
import Data.Product as P
|
||||
open import Cat.Prelude as P hiding (_×_ ; fst ; snd)
|
||||
open import Cat.Equivalence
|
||||
|
||||
open import Cat.Category
|
||||
|
||||
module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
||||
|
||||
open Category ℂ
|
||||
|
||||
module _ (A B : Object) where
|
||||
record RawProduct : Set (ℓa ⊔ ℓb) where
|
||||
no-eta-equality
|
||||
-- no-eta-equality
|
||||
field
|
||||
object : Object
|
||||
proj₁ : ℂ [ object , A ]
|
||||
proj₂ : ℂ [ object , B ]
|
||||
fst : ℂ [ object , A ]
|
||||
snd : ℂ [ object , B ]
|
||||
|
||||
-- FIXME Not sure this is actually a proposition - so this name is
|
||||
-- misleading.
|
||||
record IsProduct (raw : RawProduct) : Set (ℓa ⊔ ℓb) where
|
||||
open RawProduct raw public
|
||||
field
|
||||
ump : ∀ {X : Object} (f : ℂ [ X , A ]) (g : ℂ [ X , B ])
|
||||
→ ∃![ f×g ] (ℂ [ proj₁ ∘ f×g ] ≡ f P.× ℂ [ proj₂ ∘ f×g ] ≡ g)
|
||||
→ ∃![ f×g ] (ℂ [ fst ∘ f×g ] ≡ f P.× ℂ [ snd ∘ f×g ] ≡ g)
|
||||
|
||||
-- | Arrow product
|
||||
_P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ])
|
||||
→ ℂ [ X , object ]
|
||||
_P[_×_] π₁ π₂ = P.proj₁ (ump π₁ π₂)
|
||||
_P[_×_] π₁ π₂ = P.fst (ump π₁ π₂)
|
||||
|
||||
record Product : Set (ℓa ⊔ ℓb) where
|
||||
field
|
||||
|
|
@ -50,38 +47,133 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
|
|||
-- The product mentioned in awodey in Def 6.1 is not the regular product of
|
||||
-- arrows. It's a "parallel" product
|
||||
module _ {A A' B B' : Object} where
|
||||
open Product
|
||||
open Product (product A B) hiding (_P[_×_]) renaming (proj₁ to fst ; proj₂ to snd)
|
||||
open Product using (_P[_×_])
|
||||
open Product (product A B) hiding (_P[_×_]) renaming (fst to fst ; snd to snd)
|
||||
_|×|_ : ℂ [ A , A' ] → ℂ [ B , B' ] → ℂ [ A × B , A' × B' ]
|
||||
f |×| g = product A' B'
|
||||
P[ ℂ [ f ∘ fst ]
|
||||
× ℂ [ g ∘ snd ]
|
||||
]
|
||||
|
||||
module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object ℂ} where
|
||||
module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb}
|
||||
(let module ℂ = Category ℂ) {𝒜 ℬ : ℂ.Object} where
|
||||
private
|
||||
open Category ℂ
|
||||
module _ (raw : RawProduct ℂ A B) where
|
||||
module _ (x y : IsProduct ℂ A B raw) where
|
||||
private
|
||||
module x = IsProduct x
|
||||
module y = IsProduct y
|
||||
module _ (raw : RawProduct ℂ 𝒜 ℬ) where
|
||||
private
|
||||
open Category ℂ hiding (raw)
|
||||
module _ (x y : IsProduct ℂ 𝒜 ℬ raw) where
|
||||
private
|
||||
module x = IsProduct x
|
||||
module y = IsProduct y
|
||||
|
||||
module _ {X : Object} (f : ℂ [ X , A ]) (g : ℂ [ X , B ]) where
|
||||
prodAux : x.ump f g ≡ y.ump f g
|
||||
prodAux = {!!}
|
||||
module _ {X : Object} (f : ℂ [ X , 𝒜 ]) (g : ℂ [ X , ℬ ]) where
|
||||
module _ (f×g : Arrow X y.object) where
|
||||
help : isProp (∀{y} → (ℂ [ y.fst ∘ y ] ≡ f) P.× (ℂ [ y.snd ∘ y ] ≡ g) → f×g ≡ y)
|
||||
help = propPiImpl (λ _ → propPi (λ _ → arrowsAreSets _ _))
|
||||
|
||||
propIsProduct' : x ≡ y
|
||||
propIsProduct' i = record { ump = λ f g → prodAux f g i }
|
||||
res = ∃-unique (x.ump f g) (y.ump f g)
|
||||
|
||||
propIsProduct : isProp (IsProduct ℂ A B raw)
|
||||
prodAux : x.ump f g ≡ y.ump f g
|
||||
prodAux = lemSig ((λ f×g → propSig (propSig (arrowsAreSets _ _) λ _ → arrowsAreSets _ _) (λ _ → help f×g))) _ _ res
|
||||
|
||||
propIsProduct' : x ≡ y
|
||||
propIsProduct' i = record { ump = λ f g → prodAux f g i }
|
||||
|
||||
propIsProduct : isProp (IsProduct ℂ 𝒜 ℬ raw)
|
||||
propIsProduct = propIsProduct'
|
||||
|
||||
Product≡ : {x y : Product ℂ A B} → (Product.raw x ≡ Product.raw y) → x ≡ y
|
||||
Product≡ {x} {y} p i = record { raw = p i ; isProduct = q i }
|
||||
where
|
||||
q : (λ i → IsProduct ℂ A B (p i)) [ Product.isProduct x ≡ Product.isProduct y ]
|
||||
q = lemPropF propIsProduct p
|
||||
Product≡ : {x y : Product ℂ 𝒜 ℬ} → (Product.raw x ≡ Product.raw y) → x ≡ y
|
||||
Product≡ {x} {y} p i = record { raw = p i ; isProduct = q i }
|
||||
where
|
||||
q : (λ i → IsProduct ℂ 𝒜 ℬ (p i)) [ Product.isProduct x ≡ Product.isProduct y ]
|
||||
q = lemPropF propIsProduct p
|
||||
|
||||
open P
|
||||
open import Cat.Categories.Span
|
||||
|
||||
open Category (span ℂ 𝒜 ℬ)
|
||||
|
||||
lemma : Terminal ≃ Product ℂ 𝒜 ℬ
|
||||
lemma = fromIsomorphism Terminal (Product ℂ 𝒜 ℬ) (f , g , inv)
|
||||
where
|
||||
f : Terminal → Product ℂ 𝒜 ℬ
|
||||
f ((X , x0 , x1) , uniq) = p
|
||||
where
|
||||
rawP : RawProduct ℂ 𝒜 ℬ
|
||||
rawP = record
|
||||
{ object = X
|
||||
; fst = x0
|
||||
; snd = x1
|
||||
}
|
||||
-- open RawProduct rawP renaming (fst to x0 ; snd to x1)
|
||||
module _ {Y : ℂ.Object} (p0 : ℂ [ Y , 𝒜 ]) (p1 : ℂ [ Y , ℬ ]) where
|
||||
uy : isContr (Arrow (Y , p0 , p1) (X , x0 , x1))
|
||||
uy = uniq {Y , p0 , p1}
|
||||
open Σ uy renaming (fst to Y→X ; snd to contractible)
|
||||
open Σ Y→X renaming (fst to p0×p1 ; snd to cond)
|
||||
ump : ∃![ f×g ] (ℂ [ x0 ∘ f×g ] ≡ p0 P.× ℂ [ x1 ∘ f×g ] ≡ p1)
|
||||
ump = p0×p1 , cond , λ {f} cond-f → cong fst (contractible (f , cond-f))
|
||||
isP : IsProduct ℂ 𝒜 ℬ rawP
|
||||
isP = record { ump = ump }
|
||||
p : Product ℂ 𝒜 ℬ
|
||||
p = record
|
||||
{ raw = rawP
|
||||
; isProduct = isP
|
||||
}
|
||||
g : Product ℂ 𝒜 ℬ → Terminal
|
||||
g p = 𝒳 , t
|
||||
where
|
||||
open Product p renaming (object to X ; fst to x₀ ; snd to x₁) using ()
|
||||
module p = Product p
|
||||
module isp = IsProduct p.isProduct
|
||||
𝒳 : Object
|
||||
𝒳 = X , x₀ , x₁
|
||||
module _ {𝒴 : Object} where
|
||||
open Σ 𝒴 renaming (fst to Y)
|
||||
open Σ (snd 𝒴) renaming (fst to y₀ ; snd to y₁)
|
||||
ump = p.ump y₀ y₁
|
||||
open Σ ump renaming (fst to f')
|
||||
open Σ (snd ump) renaming (fst to f'-cond)
|
||||
𝒻 : Arrow 𝒴 𝒳
|
||||
𝒻 = f' , f'-cond
|
||||
contractible : (f : Arrow 𝒴 𝒳) → 𝒻 ≡ f
|
||||
contractible ff@(f , f-cond) = res
|
||||
where
|
||||
k : f' ≡ f
|
||||
k = snd (snd ump) f-cond
|
||||
prp : (a : ℂ.Arrow Y X) → isProp
|
||||
( (ℂ [ x₀ ∘ a ] ≡ y₀)
|
||||
× (ℂ [ x₁ ∘ a ] ≡ y₁)
|
||||
)
|
||||
prp f f0 f1 = Σ≡
|
||||
(ℂ.arrowsAreSets _ _ (fst f0) (fst f1))
|
||||
(ℂ.arrowsAreSets _ _ (snd f0) (snd f1))
|
||||
h :
|
||||
( λ i
|
||||
→ ℂ [ x₀ ∘ k i ] ≡ y₀
|
||||
× ℂ [ x₁ ∘ k i ] ≡ y₁
|
||||
) [ f'-cond ≡ f-cond ]
|
||||
h = lemPropF prp k
|
||||
res : (f' , f'-cond) ≡ (f , f-cond)
|
||||
res = Σ≡ k h
|
||||
t : IsTerminal 𝒳
|
||||
t {𝒴} = 𝒻 , contractible
|
||||
ve-re : ∀ x → g (f x) ≡ x
|
||||
ve-re x = Propositionality.propTerminal _ _
|
||||
re-ve : ∀ p → f (g p) ≡ p
|
||||
re-ve p = Product≡ e
|
||||
where
|
||||
module p = Product p
|
||||
-- RawProduct does not have eta-equality.
|
||||
e : Product.raw (f (g p)) ≡ Product.raw p
|
||||
RawProduct.object (e i) = p.object
|
||||
RawProduct.fst (e i) = p.fst
|
||||
RawProduct.snd (e i) = p.snd
|
||||
inv : AreInverses f g
|
||||
inv = funExt ve-re , funExt re-ve
|
||||
|
||||
propProduct : isProp (Product ℂ 𝒜 ℬ)
|
||||
propProduct = equivPreservesNType {n = ⟨-1⟩} lemma Propositionality.propTerminal
|
||||
|
||||
module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object ℂ} where
|
||||
open Category ℂ
|
||||
|
|
@ -90,31 +182,9 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object
|
|||
private
|
||||
module x = HasProducts x
|
||||
module y = HasProducts y
|
||||
module _ (A B : Object) where
|
||||
module pX = Product (x.product A B)
|
||||
module pY = Product (y.product A B)
|
||||
objEq : pX.object ≡ pY.object
|
||||
objEq = {!!}
|
||||
proj₁Eq : (λ i → ℂ [ objEq i , A ]) [ pX.proj₁ ≡ pY.proj₁ ]
|
||||
proj₁Eq = {!!}
|
||||
proj₂Eq : (λ i → ℂ [ objEq i , B ]) [ pX.proj₂ ≡ pY.proj₂ ]
|
||||
proj₂Eq = {!!}
|
||||
rawEq : pX.raw ≡ pY.raw
|
||||
RawProduct.object (rawEq i) = objEq i
|
||||
RawProduct.proj₁ (rawEq i) = {!!}
|
||||
RawProduct.proj₂ (rawEq i) = {!!}
|
||||
|
||||
isEq : (λ i → IsProduct ℂ A B (rawEq i)) [ pX.isProduct ≡ pY.isProduct ]
|
||||
isEq = {!!}
|
||||
|
||||
appEq : x.product A B ≡ y.product A B
|
||||
appEq = Product≡ rawEq
|
||||
|
||||
productEq : x.product ≡ y.product
|
||||
productEq i = λ A B → appEq A B i
|
||||
|
||||
propHasProducts' : x ≡ y
|
||||
propHasProducts' i = record { product = productEq i }
|
||||
productEq = funExt λ A → funExt λ B → propProduct _ _
|
||||
|
||||
propHasProducts : isProp (HasProducts ℂ)
|
||||
propHasProducts = propHasProducts'
|
||||
propHasProducts x y i = record { product = productEq x y i }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
{-# OPTIONS --allow-unsolved-metas --cubical #-}
|
||||
{-# OPTIONS --cubical #-}
|
||||
|
||||
module Cat.Category.Yoneda where
|
||||
|
||||
|
|
@ -6,9 +6,12 @@ open import Cat.Prelude
|
|||
|
||||
open import Cat.Category
|
||||
open import Cat.Category.Functor
|
||||
|
||||
open import Cat.Categories.Fun
|
||||
open import Cat.Category.NaturalTransformation
|
||||
renaming (module Properties to F)
|
||||
using ()
|
||||
open import Cat.Categories.Opposite
|
||||
open import Cat.Categories.Sets hiding (presheaf)
|
||||
open import Cat.Categories.Fun using (module Fun)
|
||||
|
||||
-- There is no (small) category of categories. So we won't use _⇑_ from
|
||||
-- `HasExponential`
|
||||
|
|
@ -47,10 +50,11 @@ module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where
|
|||
open RawFunctor rawYoneda hiding (fmap)
|
||||
|
||||
isIdentity : IsIdentity
|
||||
isIdentity {c} = lemSig (naturalIsProp {F = presheaf c} {presheaf c}) _ _ eq
|
||||
isIdentity {c} = lemSig prp _ _ eq
|
||||
where
|
||||
eq : (λ C x → ℂ [ ℂ.𝟙 ∘ x ]) ≡ identityTrans (presheaf c)
|
||||
eq : (λ C x → ℂ [ ℂ.identity ∘ x ]) ≡ identityTrans (presheaf c)
|
||||
eq = funExt λ A → funExt λ B → ℂ.leftIdentity
|
||||
prp = F.naturalIsProp _ _ {F = presheaf c} {presheaf c}
|
||||
|
||||
isDistributive : IsDistributive
|
||||
isDistributive {A} {B} {C} {f = f} {g}
|
||||
|
|
|
|||
|
|
@ -1,11 +1,23 @@
|
|||
{-# OPTIONS --allow-unsolved-metas --cubical #-}
|
||||
{-# 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 hiding (inverse)
|
||||
open import Cubical.PathPrelude using (isEquiv ; isContr ; fiber) public
|
||||
open import Cubical.GradLemma
|
||||
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
|
||||
|
|
@ -14,46 +26,90 @@ module _ {ℓa ℓb : Level} where
|
|||
module _ {A : Set ℓa} {B : Set ℓb} where
|
||||
-- Quasi-inverse in [HoTT] §2.4.6
|
||||
-- FIXME Maybe rename?
|
||||
record AreInverses (f : A → B) (g : B → A) : Set ℓ where
|
||||
field
|
||||
verso-recto : g ∘ f ≡ idFun A
|
||||
recto-verso : f ∘ g ≡ idFun B
|
||||
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
|
||||
toPair : Σ _ _
|
||||
toPair = verso-recto , recto-verso
|
||||
|
||||
Isomorphism : (f : A → B) → Set _
|
||||
Isomorphism f = Σ (B → A) λ g → AreInverses f g
|
||||
|
||||
module _ {f : A → B} {g : B → A}
|
||||
(inv : (g ∘ f) ≡ idFun A
|
||||
× (f ∘ g) ≡ idFun B) where
|
||||
open Σ inv renaming (fst to ve-re ; snd to re-ve)
|
||||
toAreInverses : AreInverses f g
|
||||
toAreInverses = record
|
||||
{ verso-recto = ve-re
|
||||
; recto-verso = re-ve
|
||||
}
|
||||
|
||||
_≅_ : 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 = record
|
||||
{ verso-recto = ve-re
|
||||
; recto-verso = re-ve
|
||||
}
|
||||
propAreInverses x y i = ve-re , re-ve
|
||||
where
|
||||
open AreInverses
|
||||
ve-re : g ∘ f ≡ idFun A
|
||||
ve-re = s (g ∘ f) (idFun A) (verso-recto x) (verso-recto y) i
|
||||
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) (recto-verso x) (recto-verso y) i
|
||||
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
|
||||
|
|
@ -74,43 +130,34 @@ module _ {ℓa ℓb ℓ : Level} (A : Set ℓa) (B : Set ℓb) where
|
|||
fromIso (toIso x) ≡⟨ propIsEquiv _ (fromIso (toIso x)) x ⟩
|
||||
x ∎
|
||||
|
||||
-- `toIso` is abstract - so I probably can't close this proof.
|
||||
-- | 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} (iso : Isomorphism f) 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)
|
||||
module inv-x = AreInverses inv-x
|
||||
module inv-y = AreInverses inv-y
|
||||
|
||||
fx≡fy : x ≡ y
|
||||
fx≡fy = begin
|
||||
x ≡⟨ cong (λ φ → x ∘ φ) (sym inv-y.recto-verso) ⟩
|
||||
x ≡⟨ cong (λ φ → x ∘ φ) (sym (snd inv-y)) ⟩
|
||||
x ∘ (f ∘ y) ≡⟨⟩
|
||||
(x ∘ f) ∘ y ≡⟨ cong (λ φ → φ ∘ y) inv-x.verso-recto ⟩
|
||||
(x ∘ f) ∘ y ≡⟨ cong (λ φ → φ ∘ y) (fst inv-x) ⟩
|
||||
y ∎
|
||||
|
||||
open import Cat.Prelude
|
||||
|
||||
propInv : ∀ g → isProp (AreInverses f g)
|
||||
propInv g t u i = record { verso-recto = a i ; recto-verso = b i }
|
||||
propInv g t u = λ i → a i , b i
|
||||
where
|
||||
module t = AreInverses t
|
||||
module u = AreInverses u
|
||||
a : t.verso-recto ≡ u.verso-recto
|
||||
a i = h
|
||||
a : (fst t) ≡ (fst u)
|
||||
a i = funExt hh
|
||||
where
|
||||
hh : ∀ a → (g ∘ f) a ≡ a
|
||||
hh a = sA ((g ∘ f) a) a (λ i → t.verso-recto i a) (λ i → u.verso-recto i a) i
|
||||
h : g ∘ f ≡ idFun A
|
||||
h i a = hh a i
|
||||
b : t.recto-verso ≡ u.recto-verso
|
||||
b i = h
|
||||
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 → t.recto-verso i b) (λ i → u.recto-verso i b) i
|
||||
h : f ∘ g ≡ idFun B
|
||||
h i b = hh b i
|
||||
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
|
||||
|
|
@ -118,11 +165,12 @@ module _ {ℓa ℓb ℓ : Level} (A : Set ℓa) (B : Set ℓb) where
|
|||
propIso : iso-x ≡ iso-y
|
||||
propIso i = fx≡fy i , inx≡iny i
|
||||
|
||||
inverse-to-from-iso : (toIso {f} ∘ fromIso {f}) iso ≡ iso
|
||||
inverse-to-from-iso = begin
|
||||
(toIso ∘ fromIso) iso ≡⟨⟩
|
||||
toIso (fromIso iso) ≡⟨ propIso _ _ ⟩
|
||||
iso ∎
|
||||
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
|
||||
|
|
@ -132,20 +180,17 @@ module _ {ℓa ℓb ℓ : Level} (A : Set ℓa) (B : Set ℓb) where
|
|||
|
||||
module _ {ℓa ℓb : Level} (A : Set ℓa) (B : Set ℓb) where
|
||||
-- A wrapper around PathPrelude.≃
|
||||
open Cubical.PathPrelude using (_≃_ ; isEquiv)
|
||||
open Cubical.PathPrelude using (_≃_)
|
||||
private
|
||||
module _ {obverse : A → B} (e : isEquiv A B obverse) where
|
||||
inverse : B → A
|
||||
inverse b = fst (fst (e b))
|
||||
inverse b = fst (fst (e .equiv-proof b))
|
||||
|
||||
reverse : B → A
|
||||
reverse = inverse
|
||||
|
||||
areInverses : AreInverses obverse inverse
|
||||
areInverses = record
|
||||
{ verso-recto = funExt verso-recto
|
||||
; recto-verso = funExt recto-verso
|
||||
}
|
||||
areInverses = funExt verso-recto , funExt recto-verso
|
||||
where
|
||||
recto-verso : ∀ b → (obverse ∘ inverse) b ≡ b
|
||||
recto-verso b = begin
|
||||
|
|
@ -153,7 +198,7 @@ module _ {ℓa ℓb : Level} (A : Set ℓa) (B : Set ℓb) where
|
|||
b ∎
|
||||
where
|
||||
μ : (b : B) → b ≡ obverse (inverse b)
|
||||
μ b = snd (fst (e b))
|
||||
μ b = snd (fst (e .equiv-proof b))
|
||||
verso-recto : ∀ a → (inverse ∘ obverse) a ≡ a
|
||||
verso-recto a = begin
|
||||
(inverse ∘ obverse) a ≡⟨ sym h ⟩
|
||||
|
|
@ -161,7 +206,7 @@ module _ {ℓa ℓb : Level} (A : Set ℓa) (B : Set ℓb) where
|
|||
a ∎
|
||||
where
|
||||
c : isContr (fiber obverse (obverse a))
|
||||
c = e (obverse a)
|
||||
c = e .equiv-proof (obverse a)
|
||||
fbr : fiber obverse (obverse a)
|
||||
fbr = fst c
|
||||
a' : A
|
||||
|
|
@ -186,105 +231,314 @@ module _ {ℓa ℓb : Level} (A : Set ℓa) (B : Set ℓb) where
|
|||
≃isEquiv : Equiv A B (isEquiv A B)
|
||||
Equiv.fromIso ≃isEquiv {f} (f~ , iso) = gradLemma f f~ rv vr
|
||||
where
|
||||
open AreInverses iso
|
||||
rv : (b : B) → _ ≡ b
|
||||
rv b i = recto-verso i b
|
||||
rv b i = snd iso i b
|
||||
vr : (a : A) → _ ≡ a
|
||||
vr a i = verso-recto i a
|
||||
vr a i = fst iso i a
|
||||
Equiv.toIso ≃isEquiv = toIsomorphism
|
||||
Equiv.propIsEquiv ≃isEquiv = P.propIsEquiv
|
||||
where
|
||||
import Cubical.NType.Properties as P
|
||||
|
||||
module Equiv≃ where
|
||||
open Equiv ≃isEquiv public
|
||||
open Equiv ≃isEquiv public
|
||||
|
||||
module _ {ℓa ℓb : Level} {A : Set ℓa} {B : Set ℓb} where
|
||||
open Cubical.PathPrelude using (_≃_)
|
||||
|
||||
-- Gives the quasi inverse from an equivalence.
|
||||
module Equivalence (e : A ≃ B) where
|
||||
open Equiv≃ A B public
|
||||
private
|
||||
iso : Isomorphism (fst e)
|
||||
iso = snd (toIsomorphism e)
|
||||
module _ {ℓc : Level} {C : Set ℓc} {f : A → B} {g : B → C} where
|
||||
|
||||
open AreInverses (snd iso) public
|
||||
|
||||
composeIso : {ℓc : Level} {C : Set ℓc} → (B ≅ C) → A ≅ C
|
||||
composeIso {C = C} (g , g' , iso-g) = g ∘ obverse , inverse ∘ g' , inv
|
||||
composeIsomorphism : Isomorphism f → Isomorphism g → Isomorphism (g ∘ f)
|
||||
composeIsomorphism a b = f~ ∘ g~ , inv
|
||||
where
|
||||
module iso-g = AreInverses iso-g
|
||||
inv : AreInverses (g ∘ obverse) (inverse ∘ g')
|
||||
AreInverses.verso-recto inv = begin
|
||||
(inverse ∘ g') ∘ (g ∘ obverse) ≡⟨⟩
|
||||
(inverse ∘ (g' ∘ g) ∘ obverse)
|
||||
≡⟨ cong (λ φ → φ ∘ obverse) (cong (λ φ → inverse ∘ φ) iso-g.verso-recto) ⟩
|
||||
(inverse ∘ idFun B ∘ obverse) ≡⟨⟩
|
||||
(inverse ∘ obverse) ≡⟨ verso-recto ⟩
|
||||
idFun A ∎
|
||||
AreInverses.recto-verso inv = begin
|
||||
g ∘ obverse ∘ inverse ∘ g'
|
||||
≡⟨ cong (λ φ → φ ∘ g') (cong (λ φ → g ∘ φ) recto-verso) ⟩
|
||||
g ∘ idFun B ∘ g' ≡⟨⟩
|
||||
g ∘ g' ≡⟨ iso-g.recto-verso ⟩
|
||||
idFun C ∎
|
||||
|
||||
compose : {ℓc : Level} {C : Set ℓc} → (B ≃ C) → A ≃ C
|
||||
compose {C = C} e = A≃C.fromIsomorphism is
|
||||
where
|
||||
module B≃C = Equiv≃ B C
|
||||
module A≃C = Equiv≃ A C
|
||||
is : A ≅ C
|
||||
is = composeIso (B≃C.toIsomorphism e)
|
||||
|
||||
symmetryIso : B ≅ A
|
||||
symmetryIso
|
||||
= inverse
|
||||
, obverse
|
||||
, record
|
||||
{ verso-recto = recto-verso
|
||||
; recto-verso = verso-recto
|
||||
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 ∎
|
||||
}
|
||||
|
||||
symmetry : B ≃ A
|
||||
symmetry = B≃A.fromIsomorphism symmetryIso
|
||||
composeIsEquiv : isEquiv A B f → isEquiv B C g → isEquiv A C (g ∘ f)
|
||||
composeIsEquiv a b = fromIso A C (composeIsomorphism a' b')
|
||||
where
|
||||
module B≃A = Equiv≃ B A
|
||||
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
|
||||
open import Cubical.PathPrelude renaming (_≃_ to _≃η_)
|
||||
open import Cubical.Univalence using (_≃_)
|
||||
-- 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
|
||||
|
||||
doEta : A ≃ B → A ≃η B
|
||||
doEta (_≃_.con eqv isEqv) = eqv , isEqv
|
||||
|
||||
deEta : A ≃η B → A ≃ B
|
||||
deEta (eqv , isEqv) = _≃_.con eqv isEqv
|
||||
|
||||
module NoEta {ℓa ℓb : Level} {A : Set ℓa} {B : Set ℓb} where
|
||||
open import Cubical.PathPrelude renaming (_≃_ to _≃η_)
|
||||
open import Cubical.Univalence using (_≃_)
|
||||
|
||||
module Equivalence′ (e : A ≃ B) where
|
||||
open Equivalence (doEta e) hiding
|
||||
( toIsomorphism ; fromIsomorphism ; _~_
|
||||
; compose ; symmetryIso ; symmetry ) public
|
||||
|
||||
compose : {ℓc : Level} {C : Set ℓc} → (B ≃ C) → A ≃ C
|
||||
compose ee = deEta (Equivalence.compose (doEta e) (doEta ee))
|
||||
|
||||
symmetry : B ≃ A
|
||||
symmetry = deEta (Equivalence.symmetry (doEta e))
|
||||
|
||||
-- fromIso : {f : A → B} → Isomorphism f → isEquiv f
|
||||
-- fromIso = ?
|
||||
|
||||
-- toIso : {f : A → B} → isEquiv f → Isomorphism f
|
||||
-- toIso = ?
|
||||
|
||||
fromIsomorphism : A ≅ B → A ≃ B
|
||||
fromIsomorphism (f , iso) = _≃_.con f (Equiv≃.fromIso _ _ iso)
|
||||
|
||||
toIsomorphism : A ≃ B → A ≅ B
|
||||
toIsomorphism (_≃_.con f eqv) = f , Equiv≃.toIso _ _ eqv
|
||||
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
|
||||
|
|
|
|||
|
|
@ -3,12 +3,16 @@ module Cat.Prelude where
|
|||
|
||||
open import Agda.Primitive public
|
||||
-- FIXME Use:
|
||||
-- open import Agda.Builtin.Sigma public
|
||||
open import Agda.Builtin.Sigma public
|
||||
-- Rather than
|
||||
open import Data.Product public
|
||||
renaming (∃! to ∃!≈)
|
||||
using (_×_ ; Σ-syntax ; swap)
|
||||
|
||||
-- TODO Import Data.Function under appropriate names.
|
||||
open import Function using (_∘_ ; _∘′_ ; _$_ ; case_of_ ; flip) public
|
||||
|
||||
idFun : ∀ {a} (A : Set a) → A → A
|
||||
idFun A a = a
|
||||
|
||||
open import Cubical public
|
||||
-- FIXME rename `gradLemma` to `fromIsomorphism` - perhaps just use wrapper
|
||||
|
|
@ -17,18 +21,19 @@ open import Cubical.GradLemma
|
|||
using (gradLemma)
|
||||
public
|
||||
open import Cubical.NType
|
||||
using (⟨-2⟩ ; ⟨-1⟩ ; ⟨0⟩ ; TLevel ; HasLevel)
|
||||
using (⟨-2⟩ ; ⟨-1⟩ ; ⟨0⟩ ; TLevel ; HasLevel ; isGrpd)
|
||||
public
|
||||
open import Cubical.NType.Properties
|
||||
using
|
||||
( lemPropF ; lemSig ; lemSigP ; isSetIsProp
|
||||
; propPi ; propHasLevel ; setPi ; propSet)
|
||||
; propPi ; propPiImpl ; propHasLevel ; setPi ; propSet
|
||||
; propSig ; equivPreservesNType)
|
||||
public
|
||||
|
||||
propIsContr : {ℓ : Level} → {A : Set ℓ} → isProp (isContr A)
|
||||
propIsContr = propHasLevel ⟨-2⟩
|
||||
|
||||
open import Cubical.Sigma using (setSig ; sigPresSet) public
|
||||
open import Cubical.Sigma using (setSig ; sigPresSet ; sigPresNType) public
|
||||
|
||||
module _ (ℓ : Level) where
|
||||
-- FIXME Ask if we can push upstream.
|
||||
|
|
@ -39,27 +44,99 @@ module _ (ℓ : Level) where
|
|||
hSet : Set (lsuc ℓ)
|
||||
hSet = ⟨0⟩ -type
|
||||
|
||||
Prop : Set (lsuc ℓ)
|
||||
Prop = ⟨-1⟩ -type
|
||||
hProp : Set (lsuc ℓ)
|
||||
hProp = ⟨-1⟩ -type
|
||||
|
||||
-----------------
|
||||
-- * Utilities --
|
||||
-----------------
|
||||
|
||||
-- | Unique existensials.
|
||||
-- | Unique existentials.
|
||||
∃! : ∀ {a b} {A : Set a}
|
||||
→ (A → Set b) → Set (a ⊔ b)
|
||||
∃! = ∃!≈ _≡_
|
||||
|
||||
∃!-syntax : ∀ {a b} {A : Set a} → (A → Set b) → Set (a ⊔ b)
|
||||
∃!-syntax = ∃
|
||||
∃!-syntax = ∃!
|
||||
|
||||
syntax ∃!-syntax (λ x → B) = ∃![ x ] B
|
||||
|
||||
module _ {ℓa ℓb} {A : Set ℓa} {P : A → Set ℓb} (f g : ∃! P) where
|
||||
∃-unique : fst f ≡ fst g
|
||||
∃-unique = (snd (snd f)) (fst (snd g))
|
||||
|
||||
module _ {ℓa ℓb : Level} {A : Set ℓa} {B : A → Set ℓb} {a b : Σ A B}
|
||||
(proj₁≡ : (λ _ → A) [ proj₁ a ≡ proj₁ b ])
|
||||
(proj₂≡ : (λ i → B (proj₁≡ i)) [ proj₂ a ≡ proj₂ b ]) where
|
||||
(fst≡ : (λ _ → A) [ fst a ≡ fst b ])
|
||||
(snd≡ : (λ i → B (fst≡ i)) [ snd a ≡ snd b ]) where
|
||||
|
||||
Σ≡ : a ≡ b
|
||||
proj₁ (Σ≡ i) = proj₁≡ i
|
||||
proj₂ (Σ≡ i) = proj₂≡ i
|
||||
fst (Σ≡ i) = fst≡ i
|
||||
snd (Σ≡ i) = snd≡ i
|
||||
|
||||
import Relation.Binary
|
||||
open Relation.Binary public using
|
||||
( Preorder ; Transitive ; IsEquivalence ; Rel
|
||||
; Setoid )
|
||||
|
||||
equalityIsEquivalence : {ℓ : Level} {A : Set ℓ} → IsEquivalence {A = A} _≡_
|
||||
IsEquivalence.refl equalityIsEquivalence = refl
|
||||
IsEquivalence.sym equalityIsEquivalence = sym
|
||||
IsEquivalence.trans equalityIsEquivalence = trans
|
||||
|
||||
IsPreorder
|
||||
: {a ℓ : Level} {A : Set a}
|
||||
→ (_∼_ : Rel A ℓ) -- The relation.
|
||||
→ Set _
|
||||
IsPreorder _~_ = Relation.Binary.IsPreorder _≡_ _~_
|
||||
|
||||
module _ {ℓ : Level} {A : Set ℓ} {a : A} where
|
||||
-- FIXME rename to `coe-neutral`
|
||||
id-coe : coe refl a ≡ a
|
||||
id-coe = begin
|
||||
coe refl a ≡⟨⟩
|
||||
pathJ (λ y x → A) _ A refl ≡⟨ pathJprop {x = a} (λ y x → A) _ ⟩
|
||||
_ ≡⟨ pathJprop {x = a} (λ y x → A) _ ⟩
|
||||
a ∎
|
||||
|
||||
module _ {ℓ : Level} {A : Set ℓ} where
|
||||
open import Cubical.NType
|
||||
open import Data.Nat using (_≤′_ ; ≤′-refl ; ≤′-step ; zero ; suc)
|
||||
open import Cubical.NType.Properties
|
||||
ntypeCumulative : ∀ {n m} → n ≤′ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A
|
||||
ntypeCumulative {m} ≤′-refl lvl = lvl
|
||||
ntypeCumulative {n} {suc m} (≤′-step le) lvl = HasLevel+1 ⟨ m ⟩₋₂ (ntypeCumulative le lvl)
|
||||
|
||||
grpdPi : {ℓb : Level} {B : A → Set ℓb}
|
||||
→ ((a : A) → isGrpd (B a)) → isGrpd ((a : A) → (B a))
|
||||
grpdPi = piPresNType (S (S (S ⟨-2⟩)))
|
||||
|
||||
grpdPiImpl : {ℓb : Level} {B : A → Set ℓb}
|
||||
→ ({a : A} → isGrpd (B a)) → isGrpd ({a : A} → (B a))
|
||||
grpdPiImpl {B = B} g = equivPreservesNType {A = Expl} {B = Impl} {n = one} e (grpdPi (λ a → g))
|
||||
where
|
||||
one = (S (S (S ⟨-2⟩)))
|
||||
t : ({a : A} → HasLevel one (B a))
|
||||
t = g
|
||||
Impl = {a : A} → B a
|
||||
Expl = (a : A) → B a
|
||||
expl : Impl → Expl
|
||||
expl f a = f {a}
|
||||
impl : Expl → Impl
|
||||
impl f {a} = f a
|
||||
e : Expl ≃ Impl
|
||||
e = impl , (gradLemma impl expl (λ f → refl) (λ f → refl))
|
||||
|
||||
setGrpd : isSet A → isGrpd A
|
||||
setGrpd = ntypeCumulative
|
||||
{suc (suc zero)} {suc (suc (suc zero))}
|
||||
(≤′-step ≤′-refl)
|
||||
|
||||
propGrpd : isProp A → isGrpd A
|
||||
propGrpd = ntypeCumulative
|
||||
{suc zero} {suc (suc (suc zero))}
|
||||
(≤′-step (≤′-step ≤′-refl))
|
||||
|
||||
module _ {ℓa ℓb : Level} {A : Set ℓa} {B : A → Set ℓb} where
|
||||
open TLevel
|
||||
grpdSig : isGrpd A → (∀ a → isGrpd (B a)) → isGrpd (Σ A B)
|
||||
grpdSig = sigPresNType {n = S (S (S ⟨-2⟩))}
|
||||
|
|
|
|||
|
|
@ -1,41 +0,0 @@
|
|||
{-# OPTIONS --allow-unsolved-metas #-}
|
||||
module Cat.Wishlist where
|
||||
|
||||
open import Level hiding (suc)
|
||||
open import Cubical
|
||||
open import Cubical.NType
|
||||
open import Data.Nat using (_≤_ ; z≤n ; s≤s ; zero ; suc)
|
||||
open import Agda.Builtin.Sigma
|
||||
|
||||
open import Cubical.NType.Properties
|
||||
|
||||
step : ∀ {ℓ} {A : Set ℓ} → isContr A → (x y : A) → isContr (x ≡ y)
|
||||
step (a , contr) x y = {!p , c!}
|
||||
-- where
|
||||
-- p : x ≡ y
|
||||
-- p = begin
|
||||
-- x ≡⟨ sym (contr x) ⟩
|
||||
-- a ≡⟨ contr y ⟩
|
||||
-- y ∎
|
||||
-- c : (q : x ≡ y) → p ≡ q
|
||||
-- c q i j = contr (p {!!}) {!!}
|
||||
|
||||
-- Contractible types have any given homotopy level.
|
||||
contrInitial : {ℓ : Level} {A : Set ℓ} → ∀ n → isContr A → HasLevel n A
|
||||
contrInitial ⟨-2⟩ contr = contr
|
||||
-- lem' (S ⟨-2⟩) (a , contr) = {!step!}
|
||||
contrInitial (S ⟨-2⟩) (a , contr) x y = begin
|
||||
x ≡⟨ sym (contr x) ⟩
|
||||
a ≡⟨ contr y ⟩
|
||||
y ∎
|
||||
contrInitial (S (S n)) contr x y = {!lvl!} -- Why is this not well-founded?
|
||||
where
|
||||
c : isContr (x ≡ y)
|
||||
c = step contr x y
|
||||
lvl : HasLevel (S n) (x ≡ y)
|
||||
lvl = contrInitial {A = x ≡ y} (S n) c
|
||||
|
||||
module _ {ℓ : Level} {A : Set ℓ} where
|
||||
ntypeCommulative : ∀ {n m} → n ≤ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A
|
||||
ntypeCommulative {n = zero} {m} z≤n lvl = {!contrInitial ⟨ m ⟩₋₂ lvl!}
|
||||
ntypeCommulative {n = .(suc _)} {.(suc _)} (s≤s x) lvl = {!!}
|
||||
Loading…
Reference in New Issue