diff --git a/.gitignore b/.gitignore deleted file mode 100644 index 6f49e84..0000000 --- a/.gitignore +++ /dev/null @@ -1 +0,0 @@ -references/ diff --git a/BACKLOG.md b/BACKLOG.md index 91d6b63..af3f622 100644 --- a/BACKLOG.md +++ b/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 --------------------- diff --git a/CHANGELOG.md b/CHANGELOG.md index 42ab3e0..6bb631b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,32 @@ -Changelog +Change log ========= +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 +55,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 +68,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 +79,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 diff --git a/proposal/.gitignore b/doc/.gitignore similarity index 90% rename from proposal/.gitignore rename to doc/.gitignore index b19d31d..bc1675b 100644 --- a/proposal/.gitignore +++ b/doc/.gitignore @@ -6,3 +6,4 @@ *.pdf *.bbl *.blg +*.toc diff --git a/doc/BACKLOG.md b/doc/BACKLOG.md new file mode 100644 index 0000000..8bf5f45 --- /dev/null +++ b/doc/BACKLOG.md @@ -0,0 +1,7 @@ +Talk about structure of library: +=== + +What can I say about reusability? + +Misc +==== diff --git a/proposal/Makefile b/doc/Makefile similarity index 84% rename from proposal/Makefile rename to doc/Makefile index 8561a59..ff8e36c 100644 --- a/proposal/Makefile +++ b/doc/Makefile @@ -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,8 +40,8 @@ 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 diff --git a/doc/appendix.tex b/doc/appendix.tex new file mode 100644 index 0000000..0c3affb --- /dev/null +++ b/doc/appendix.tex @@ -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} diff --git a/doc/chalmerstitle.sty b/doc/chalmerstitle.sty new file mode 100644 index 0000000..a31e8a2 --- /dev/null +++ b/doc/chalmerstitle.sty @@ -0,0 +1,135 @@ +% 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} +\begingroup +\thispagestyle{empty} +{\Huge\@title}\\[.5cm] +{\Large A formalization of category theory in Cubical Agda}\\[2.5cm] +\begin{center} +\includegraphics[width=\linewidth,keepaspectratio]{isomorphism.png} +\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]{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}} diff --git a/doc/conclusion.tex b/doc/conclusion.tex new file mode 100644 index 0000000..834e579 --- /dev/null +++ b/doc/conclusion.tex @@ -0,0 +1,3 @@ +\chapter{Conclusion} + +\TODO{\ldots} diff --git a/doc/cubical.tex b/doc/cubical.tex new file mode 100644 index 0000000..8ccd666 --- /dev/null +++ b/doc/cubical.tex @@ -0,0 +1,286 @@ +\chapter{Cubical Agda} +\section{Propositional equality} +In Agda judgmental equality is a feature of the type-system. It's a property of +types that can be checked by computational means. In the example from the +introduction $n + 0$ can be judged to be equal to $n$ simply by expanding the +definition of $+$. + +Propositional equality on the other hand is defined within the language itself. +Cubical Agda extends the underlying type system (\TODO{Cite someone smarter than +me with a good resource on this}) but introduces a data-type within the +languages. + +Exceprts of the source code relevant to this section can be found in appendix +\ref{sec:app-cubical}. + +\subsection{The equality type} +The usual notion of judgmental equality says that given a type $A \tp \MCU$ and +two points of $A$; $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: +% +\begin{align} + \refl \tp a \equiv a +\end{align} +% +For any $a \tp A$. + +There also exist a related notion of \emph{heterogeneous} equality where 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 is likewise defined as an inductive data-type with a single constructors: +% +\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} +In Cubical Agda judgmental equality is encapsulated with the type: +% +$$ +\Path \tp (P \tp I → \MCU) → P\ 0 → P\ 1 → \MCU +$$ +% +$I$ is a special data-type (\TODO{that also has special computational properties + AFAIK}) called the index set. $I$ can be thought of simply as the interval on +the real numbers from $0$ to $1$. $P$ is a family of types over the index set +$I$. I will sometimes refer to $P$ as the ``path-space'' of some path $p \tp +\Path\ P\ a\ b$. By this token $P\ 0$ then corresponds to the type at the +left-endpoint and $P\ 1$ as the type at the right-endpoint. The type is called +$\Path$ because it is connected with paths in homotopy theory. The intuition +behind this is that $\Path$ describes paths in $\MCU$ -- i.e. between types. For +a path $p$ for the point $p\ i$ 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, $p$, from the index-space to the path-space: +% +$$ +p \tp I \to P\ i +$$ +% +Which must satisfy being judgmentally equal to $a_0$ (respectively $a_1$) at the +endpoints. I.e.: +% +\begin{align*} + p\ 0 & = a_0 \\ + p\ 1 & = a_1 +\end{align*} +% +The notion of ``homogeneous equalities'' can be recovered by not letting the +path-space $P$ depend on it's argument: +% +$$ +a_0 \equiv a_1 \defeq \Path\ (\lambda i \to A)\ a_0\ a_1 +$$ +% +For $A \tp \MCU$, $a_0, a_1 \tp A$. I will generally prefer to use the notation +$a_0 \equiv a_1$ when talking about non-dependent paths and use the notation +$\Path\ (\lambda i \to A)\ a_0\ a_1$ when the path-space is of particular +interest. + +With this definition we can also recover reflexivity. That is, for any $A \tp +\MCU$ and $a \tp A$: +% +\begin{equation} +\begin{aligned} +\refl & \tp \Path (\lambda i \to A)\ a\ a \\ +\refl & \defeq \lambda i \to a +\end{aligned} +\end{equation} +% +Or, in other terms; reflexivity is the path in $A$ that is $a$ at the left +endpoint as well as at the right endpoint. It is inhabited by the path which +stays constantly at $a$ at any index $i$. + +Paths have some other important properties, but they are not the focus of this +thesis. \TODO{Refer the reader somewhere for more info.} +% +\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 +don't have any interesting structure. This is referred to as uniqueness of +identity proofs. Unfortunately this is orthogonal to univalence that only makes +sense in the absence of UIP. + +In homotopy type theory we have a hierarchy of types based on their ``internal +structure''. At the bottom of this hierarchy we have 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$''. It is a theorem that if a type is +contractible, then it is isomorphic to the unit-type $\top$. + +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} +% +$\isProp\ A$ can be thought of as the set of true and false propositions. It is +a result 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).\TODO{Cite!!} + +I will refer to a type $A \tp \MCU$ as a \emph{mere} proposition if I want to +stress that we have $\isProp\ A$. + +Then comes 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} +% +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 inhabited. + +The next step in the hierarchy is, as the reader might've guessed, 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} +% +And 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}, propositions +are \nomen{-1-types}, (homotopical) sets are \nomen{0-types} 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$. + +Let $\left\Vert A \right\Vert = n$ denote that the level of $A$ is $n$. +Proposition: For any homotopic level $n$ this 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 +already that have already been formalized. Specifically the results come from +the Agda library \texttt{cubical} (\TODO{Cite}). 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. As well my contribution to \texttt{cubical} can be found in the git logs \TODO{Cite}.} + +These theorems are all purely related to homotopy theory and cubical Agda 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 later in chapter +\ref{ch:implementation} throughout. + +\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 +``base-case''). For \emph{based path induction}, that equality is \emph{based} +at some element $a \tp A$. + +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. Given a family of types: +% +$$ +P \tp \prod_{a' \tp A} \prod_{p \tp a ≡ a'} \MCU +$$ +% +And an inhabitant of $P$ at $\refl$: +% +$$ +p \tp P\ a\ \refl +$$ +% +We have the function: +% +$$ +\pathJ\ P\ p \tp \prod_{a' \tp A} \prod_{p \tp a ≡ a'} P\ a\ p +$$ +% +\subsection{Paths over propositions} +\label{sec:lemPropF} +Another very useful combinator is $\lemPropF$: + +To `promote' this to a dependent path we can use another useful combinator; +$\lemPropF$. Given a type $A \tp \MCU$ and a type family on $A$; $P \tp A \to +\MCU$. Let $\var{propP} \tp \prod_{x \tp A} \isProp\ (P\ x)$ be the proof that +$P$ 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 $p_0 \tp P\ a_0$ and $p_1 \tp +P\ a_1$: +% +$$ +\lemPropF\ \var{propP}\ p \defeq \Path\ (\lambda\; i \mto P\ (p\ i))\ p_0\ p_1 +$$ +% +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, saw we have a type: +% +$$ +T \defeq \sum_{a \tp A} P\ a +$$ +% +For some proposition $P \tp A \to \MCU$. 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 P\ (p\ i))\ \snd\ t_0 \equiv \snd\ t_1 +\end{align*} +% +Here $\lemPropF$ directly allow us to prove the latter of these: +% +$$ +\lemPropF\ \var{propP}\ p + \tp \Path\ (\lambda i \to P\ (p\ i))\ \snd\ t_0 \equiv \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 it's first component is a +proposition, and it's second component is a proposition for all points of in 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) +$$ diff --git a/doc/discussion.tex b/doc/discussion.tex new file mode 100644 index 0000000..62564e6 --- /dev/null +++ b/doc/discussion.tex @@ -0,0 +1,74 @@ +\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} +Another aspect (\TODO{That I actually didn't highlight very well in the previous + chapter}) is the computational nature of paths. Say we have formalized this +common result about monads: + +\TODO{Some equation\ldots} + +By transporting this to the Kleisli formulation we get a result that we can use +to compute with. This is particularly useful because the Kleisli formulation +will be more familiar to programmers e.g. those coming from a background in +Haskell. Whereas the theory usually talks about monoidal monads. + +\TODO{Mention that with postulates we cannot do this} + +\subsection{Reusability of proofs} +The previous example also 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. + +The introduction (section \ref{sec:context}) mentioned an often +employed-technique for enabling extensional equalities is to use the +setoid-interpretation. Nowhere in this formalization has this been necessary, +$\Path$ has been used globally in the project as 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 ``unique +existential'' is indexed by a relation that should play the role of +propositional equality. Likewise for equivalence relations, they are 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 \label{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. + +\TODO{Universe levels.} + +\section{Future work} +\subsection{Agda \texttt{Prop}} +Jesper Cockx' work extending the universe-level-laws for Agda and the +\texttt{Prop}-type. + +\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. The path between monads that this library +exposes could provide one particularly interesting case-study. + +\subsection{Higher inductive types} +This library has not explored the usefulness of higher inductive types in the +context of Category Theory. diff --git a/doc/feedback.txt b/doc/feedback.txt new file mode 100644 index 0000000..e45ae95 --- /dev/null +++ b/doc/feedback.txt @@ -0,0 +1,72 @@ +Andrea Vezzosi Tue, Apr 24, 2018 at 2:02 PM +To: Frederik Hanghøj Iversen +Cc: Thierry Coquand +On Tue, Apr 24, 2018 at 12:57 PM, Frederik Hanghøj Iversen + 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] diff --git a/proposal/halftime.tex b/doc/halftime.tex similarity index 58% rename from proposal/halftime.tex rename to doc/halftime.tex index 11dc836..8381f2b 100644 --- a/proposal/halftime.tex +++ b/doc/halftime.tex @@ -1,4 +1,4 @@ -\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. @@ -8,7 +8,7 @@ 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,7 +50,7 @@ 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 @@ -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*} +% diff --git a/doc/implementation.tex b/doc/implementation.tex new file mode 100644 index 0000000..2ce0d4e --- /dev/null +++ b/doc/implementation.tex @@ -0,0 +1,1325 @@ +\chapter{Category Theory} +\label{ch:implementation} +This implementation formalizes the following concepts: +% +\begin{enumerate}[i.] +\item Categories +\item Functors +\item Products +\item Exponentials +\item Cartesian closed categories +\item Natural transformations +\item Yoneda embedding +\item Monads +\item Categories + \begin{enumerate}[i.] + \item Opposite category + \item Category of sets + \item ``Pair category'' + \end{enumerate} +\end{enumerate} +% +Furthermore the following items have been partly formalized: +% +\begin{enumerate}[i.] +\item The (higher) category of categories. +\item Category of relations +\item Category of functors and natural transformations -- only as a precategory +\item Free category +\item Monoidal objects +\item Monoidal categories +\end{enumerate} +% +As well as a range of various results about these. E.g. I have shown that the +category of sets has products. In the following I aim to demonstrate some of the +techniques employed in this formalization and in the interest of brevity I will +not detail all the things I have formalized. In stead, I have selected a parts +of this formalization that highlight some interesting proof techniques relevant +to doing proofs in Cubical Agda. + +One such technique that is pervasive to this formalization is the idea of +distinguishing types with more or less homotopical structure. To do this I have +followed the following design-principle: I have split concepts up into things +that represent ``data'' and ``laws'' about this data. The idea is that we can +provide a proof that the laws are mere propositions. As an example a category is +defined to have two members: `raw` which is a collection of the data and +`isCategory` which asserts some laws about that data. + +This allows me to reason about things in a more ``standard mathematical way'', +where one can reason about two categories by simply focusing on the data. This +is achieved by creating a function embodying the ``equality principle'' for a +given type. + +For the rest of this chapter I will present some of these results. For didactic +reasons no source-code has been included in this chapter. To see the formal +definitions excerpts of the implementation have been included in appendix +\ref{ch:app-sources}. + +\section{Categories} +The data for a category consist of a type for the sort of objects; a type for +the sort of arrows; an identity arrow and a composition operation for arrows. +Another record encapsulates some laws about this data: associativity of +composition, identity law for the identity morphism. These are standard +constituents of a category and can be found in typical mathematical expositions +on the topic. We, however, impose one further requirement on what it means to be +a category, namely that the type of arrows form a set. + +Such categories are called \nomen{1-categories}. It's possible to relax this +requirement. This would lead to the notion of higher categories (\cite[p. + 307]{hott-2013}). For the purpose of this project, however, this report will +restrict itself to 1-categories. Making based on higher categories would be a +very natural possible extension of this work. + +Raw categories satisfying all of the above requirements are called a +\nomen{pre}-categories. As a further requirement to be a proper category we +require it to be univalent. Before we can define this, I must introduce two more +definitions: If we let $p$ be a witness to the identity law, which formally is: +% +\begin{equation} + \label{eq:identity} + \var{IsIdentity} \defeq + \prod_{A\ B \tp \Object} \prod_{f \tp A \to B} + \id \comp f \equiv f \x f \comp \id \equiv f +\end{equation} +% +Then we can construct the identity isomorphism $\var{idIso} \tp \identity, +\identity, p \tp A \approxeq A$ for any object $A$. Here $\approxeq$ denotes +isomorphism on objects (whereas $\cong$ denotes isomorphism of types). This will +be elaborated further on in sections \ref{sec:equiv} and \ref{sec:univalence}. +Moreover, due to substitution for paths we can construct an isomorphism from +\emph{any} path: +% +\begin{equation} +\var{idToIso} \tp A ≡ B → A ≊ B +\end{equation} +% +The univalence criterion for categories states that this map must be an +equivalence. The requirement is similar to univalence for types, but where +isomorphism on objects play the role of equivalence on types. Formally: +% +\begin{align} +\label{eq:cat-univ} +\isEquiv\ (A \equiv B)\ (A \approxeq B)\ \idToIso +\end{align} +% +Note that \ref{eq:cat-univ} is \emph{not} the same as: +% +\begin{equation} +\label{eq:cat-univalence} +\tag{Univalence, category} +(A \equiv B) \simeq (A \approxeq B) +\end{equation} +% +However the two are logically equivalent: One can construct the latter from the +former simply by ``forgetting'' that $\idToIso$ plays the role of the +equivalence. The other direction is more involved and will be discussed in +section \ref{sec:univalence}. + +In summary, the definition of a category is the following collection of data: +% +\begin{align} + \Object & \tp \Type \\ + \Arrow & \tp \Object \to \Object \to \Type \\ + \identity & \tp \Arrow\ A\ A \\ + \lll & \tp \Arrow\ B\ C \to \Arrow\ A\ B \to \Arrow\ A\ C +\end{align} +% +And laws: +% +\begin{align} +\tag{associativity} +h \lll (g \lll f) ≡ (h \lll g) \lll f \\ +\tag{identity} +\identity \lll f ≡ f \x +f \lll \identity ≡ f +\\ +\label{eq:arrows-are-sets} +\tag{arrows are sets} +\isSet\ (\Arrow\ A\ B)\\ +\tag{\ref{eq:cat-univ}} +\isEquiv\ (A \equiv B)\ (A \approxeq B)\ \idToIso +\end{align} +% +$\lll$ denotes arrow composition (right-to-left), and reverse function +composition (left-to-right, diagrammatic order) is denoted $\rrr$. The objects +($A$, $B$ and $C$) and arrow ($f$, $g$, $h$) are implicitly universally +quantified. + +With all this in place it is now possible to prove that all the laws are indeed +mere propositions. Most of the proofs simply use the fact that the type of +arrows are sets. This is because most of the laws are a collection of equations +between arrows in the category. And since such a proof does not have any content +exactly because the type of arrows form a set, two witnesses must be the same. +All the proofs are really quite mechanical. Lets have a look at one of them. +Proving that \ref{eq:identity} is a mere proposition: +% +\begin{equation} + \isProp\ \var{IsIdentity} +\end{equation} +% +There are multiple ways to prove this. Perhaps one of the more intuitive proofs +is by way of the `combinators' $\propPi$ and $\propSig$ presented in sections +\ref{sec:propPi} and \ref{sec:propSig}: +% +\begin{align*} +\var{propPi} & \tp \left(\prod_{a \tp A} \isProp\ (P\ a)\right) \to \isProp\ \left(\prod_{a \tp A} P\ a\right) + \\ +\var{propSig} & \tp \isProp\ A \to \left(\prod_{a \tp A} \isProp\ (P\ a)\right) \to \isProp\ \left(\sum_{a \tp A} P\ a\right) +\end{align*} +% +So the proof goes like this: We `eliminate' the 3 function abstractions by +applying $\propPi$ three times. So our proof obligation becomes: +% +$$ +\isProp \left( \id \comp f \equiv f \x f \comp \id \equiv f \right) +$$ +% +Then we eliminate the (non-dependent) sigma-type by applying $\propSig$ giving +us the two obligations: $\isProp\ (\id \comp f \equiv f)$ and $\isProp\ (f \comp +\id \equiv f)$ which follows from the type of arrows being a +set. + +This example illustrates nicely how we can use these combinators to reason about +`canonical' types like $\sum$ and $\prod$. Similar combinators can be defined +at the other homotopic levels. These combinators are however not applicable in +situations where we want to reason about other types - e.g. types we've defined +ourselves. For instance, after we've proven that all the projections of +pre-categories are propositions, then we would like to bundle this up to show +that the type of pre-categories is also a proposition. Formally: +% +\begin{equation} +\label{eq:propIsPreCategory} +\isProp\ \IsPreCategory +\end{equation} +% +Where The definition of $\IsPreCategory$ is the triple: +% +\begin{align*} +\var{isAssociative} & \tp \var{IsAssociative}\\ +\var{isIdentity} & \tp \var{IsIdentity}\\ +\var{arrowsAreSets} & \tp \var{ArrowsAreSets} +\end{align*} +% +Each corresponding to the first three laws for categories. Note that since +$\IsPreCategory$ is not formulated with a chain of sigma-types we wont have any +combinators available to help us here. In stead we'll have to use the path-type +directly. + +\ref{eq:propIsPreCategory} is judgmentally the same as +% +$$ +\prod_{a\ b \tp \IsPreCategory} a \equiv b +$$ +% +So let $a\ b \tp \IsPreCategory$ be given. To prove the equality $a \equiv b$ is +to give a continuous path from the index-type into the path-space. I.e. a +function $I \to \IsPreCategory$. This path must satisfy being being judgmentally +the same as $a$ at the left endpoint and $b$ at the right endpoint. We know we +can form a continuous path between all projections of $a$ and $b$, this follows +from the type of all the projections being mere propositions. For instance, the +path between $a.\isIdentity$ and $b.\isIdentity$ is simply formed by: +% +$$ +\propIsIdentity\ a.\isIdentity\ b.\isIdentity +\tp +a.\isIdentity \equiv b.\isIdentity +$$ +% +So to give the continuous function $I \to \IsPreCategory$, which is our goal, we +introduce $i \tp I$ and proceed by constructing an element of $\IsPreCategory$ +by using the fact that all the projections are propositions to generate paths +between all projections. Once we have such a path e.g. $p \tp a.\isIdentity +\equiv b.\isIdentity$ we can eliminate it with $i$ and thus obtain $p\ i \tp +(p\ i).\isIdentity$. This element satisfies exactly that it corresponds to the +corresponding projections at either endpoint. Thus the element we construct at +$i$ becomes the triple: +% +\begin{equation} +\label{eq:proof-prop-IsPreCategory} +\begin{aligned} + & \var{propIsAssociative} && a.\var{isAssociative}\ + && b.\var{isAssociative} && i \\ + & \var{propIsIdentity} && a.\var{isIdentity}\ + && b.\var{isIdentity} && i \\ + & \var{propArrowsAreSets} && a.\var{arrowsAreSets}\ + && b.\var{arrowsAreSets} && i +\end{aligned} +\end{equation} +% +I've found this to be a general pattern when proving things in homotopy type +theory, namely that you have to wrap and unwrap equalities at different levels. +It is worth noting that proving this theorem with the regular inductive equality +type would already not be possible, since we at least need extensionality (the +projections are all $\prod$-types). Assuming we had functional extensionality +available to us as an axiom, we would use functional extensionality (in +reverse?) to retrieve the equalities in $a$ and $b$, pattern-match on them to +see that they are both $\var{refl}$ and then close the proof with $\var{refl}$. +Of course this theorem is not so interesting in the setting of ITT since we know +a priori that equality proofs are unique. + +The situation is a bit more complicated when we have a dependent type. For +instance, when we want to show that $\IsCategory$ is a mere proposition. +$\IsCategory$ is a record with two fields, a witness to being a pre-category and +the univalence condition. Recall that the univalence condition is indexed by the +identity-proof. So to follow the same recipe as above, let $a\ b \tp +\IsCategory$ be given, to show them equal, we now need to give two paths. One homogeneous: +% +$$ +p \tp a.\isPreCategory \equiv b.\isPreCategory +$$ +% +and one heterogeneous: +% +$$ +\Path\ (\lambda\; i \to (p\ i).Univalent)\ a.\isPreCategory\ b.\isPreCategory +$$ +% +Which depends on the choice of $p$. The first of these we can provide since, as +we have shown, $\IsPreCategory$ is a proposition. However, even though +$\Univalent$ is also a proposition, we cannot use this directly to show the +latter. This is because $\isProp$ talks about non-dependent paths. So we need to +'promote' the result that univalence is a proposition to a heterogeneous path. +To this end we can use $\lemPropF$, which was introduced in \ref{sec:lemPropF}. + +In this case $A = \var{IsIdentity}\ \identity$ and $B = \var{Univalent}$. We've +shown that being a category is a proposition, a result that holds for any choice +of identity proof. Finally we must provide a proof that the identity proofs at +$a$ and $b$ are indeed the same, this we can extract from $p$ by applying +congruence of paths: +% +$$ +\congruence\ \var{isIdentity}\ p +$$ +% +And this finishes the proof that being-a-category is a mere proposition +(\ref{eq:propIsPreCategory}). + +When we have a proper category we can make precise the notion of ``identifying +isomorphic types'' \TODO{cite Awodey here}. That is, we can construct the +function: +% +$$ +\isoToId \tp (A \approxeq B) \to (A \equiv B) +$$ +% +A perhaps somewhat surprising application of this is that we can show that +terminal objects are propositional: +% +\begin{align} +\label{eq:termProp} +\isProp\ \var{Terminal} +\end{align} +% +It follows from the usual observation that any two terminal objects are +isomorphic - and since categories are univalent, so are they equal. The proof is +omitted here, but the curious reader can check the implementation for the +details. \TODO{The proof is a bit fun, should I include it?} + +\section{Equivalences} +\label{sec:equiv} +The usual notion of a function $f \tp A \to B$ having an inverses is: +% +\begin{equation} +\label{eq:isomorphism} +\sum_{g \tp B \to A} f \comp g \equiv \identity_{B} \x g \comp f \equiv \identity_{A} +\end{equation} +% +This is defined in \cite[p. 129]{hott-2013} where it is referred to as the a +``quasi-inverse''. We shall refer to the type \ref{eq:isomorphism} as +$\Isomorphism\ f$. This also gives rise to the following type: +% +\begin{equation} +A \cong B \defeq \sum_{f \tp A \to B} \Isomorphism\ f +\end{equation} +% +At the same place \cite{hott-2013} gives an ``interface'' for what the judgment +$\isEquiv \tp (A \to B) \to \MCU$ must provide: +% +\begin{align} +\var{fromIso} & \tp \Isomorphism\ f \to \isEquiv\ f \\ +\var{toIso} & \tp \isEquiv\ f \to \Isomorphism\ f \\ +\label{eq:propIsEquiv} + &\mathrel{\ } \isEquiv\ f +\end{align} +% +The maps $\var{fromIso}$ and $\var{toIso}$ naturally extend to these maps: +% +\begin{align} +\var{fromIsomorphism} & \tp A \cong B \to A \simeq B \\ +\var{toIsomorphism} & \tp A \simeq B \to A \cong B +\end{align} +% +Having this interface gives us both: a way to think rather abstractly about how +to work with equivalences and a way to use ad hoc definitions of equivalences. +The specific instantiation of $\isEquiv$ as defined in \cite{cubical-agda} is: +% +$$ +isEquiv\ f \defeq \prod_{b \tp B} \isContr\ (\fiber\ f\ b) +$$ +where +$$ +\fiber\ f\ b \defeq \sum_{a \tp A} \left( b \equiv f\ a \right) +$$ +% +I give it's definition here mainly for completeness, because as I stated we can +move away from this specific instantiation and think about it more abstractly +once we have shown that this definition actually works as an equivalence. + +$\var{fromIso}$ can be found in \cite{cubical-agda} where it is known as +$\var{gradLemma}$. The implementation of $\var{fromIso}$ as well as the proof +that this equivalence is a proposition (\ref{eq:propIsEquiv}) can be found in my +implementation. + +We say that two types $A\;B \tp \Type$ are equivalent exactly if there exists an +equivalence between them: +% +\begin{equation} +\label{eq:equivalence} +A \simeq B \defeq \sum_{f \tp A \to B} \isEquiv\ f +\end{equation} +% +Note that the term equivalence here is overloaded referring both to the map $f +\tp A \to B$ and the type $A \simeq B$. The notion of an isomorphism is +similarly conflated as isomorphism can refer to the type $A \cong B$ as well as +the the map $A \to B$ that witness this. I will use these conflated terms when +it is clear from the context what is being referred to. + +Both $\cong$ and $\simeq$ form equivalence relations (no pun intended). + +\section{Univalence} +\label{sec:univalence} +As noted in the introduction the univalence for types $A\; B \tp \Type$ states +that: +% +$$ +\var{Univalence} \defeq (A \equiv B) \simeq (A \simeq B) +$$ +% +As mentioned the univalence criterion for some category $\bC$ says that for all +\emph{objects} $A\;B$ we must have: +$$ +\isEquiv\ (A \equiv B)\ (A \approxeq B)\ \idToIso +$$ +And I mentioned that this was logically equivalent to +% +$$ +(A \equiv B) \simeq (A \approxeq B) +$$ +% +Given that we saw in the previous section that we can construct an equivalence +from an isomorphism it suffices to demonstrate: +% +$$ +(A \equiv B) \cong (A \approxeq B) +$$ +% +That is, we must demonstrate that there is an isomorphism (on types) between +equalities and isomorphisms (on arrows). It's worthwhile to dwell on this for a +few seconds. This type looks very similar to univalence for types and is +therefore perhaps a bit more intuitive to grasp the implications of. Of course +univalence for types (which is a proposition -- i.e. provable) does not imply +univalence of all pre-category since morphisms in a category are not regular +functions -- in stead they can be thought of as a generalization hereof. The univalence criterion therefore is simply a way of restricting arrows +to behave similarly to maps. + +I will now mention a few helpful theorems that follow from univalence that will +become useful later. + +Obviously univalence gives us an isomorphism between $A \equiv B$ and $A +\approxeq B$. I will name these for convenience: +% +$$ +\idToIso \tp A \equiv B \to A \approxeq B +$$ +% +$$ +\isoToId \tp A \approxeq B \to A \equiv B +$$ +% +The next few theorems are variations on theorem 9.1.9 from \cite{hott-2013}. Let +an isomorphism $A \approxeq B$ in some category $\bC$ be given. Name the +isomorphism $\iota \tp A \to B$ and its inverse $\inv{\iota} \tp B \to A$. +Since $\bC$ is a category (and therefore univalent) the isomorphism induces a +path $p \tp A \equiv B$. From this equality we can get two further paths: +$p_{\var{dom}} \tp \var{Arrow}\ A\ X \equiv \var{Arrow}\ B\ X$ and +$p_{\var{cod}} \tp \var{Arrow}\ X\ A \equiv \var{Arrow}\ X\ B$. We +then have the following two theorems: +% +\begin{align} +\label{eq:coeDom} +\var{coeDom} & \tp \prod_{f \tp A \to X} +\var{coe}\ p_{\var{dom}}\ f \equiv f \lll \inv{\iota} +\\ +\label{eq:coeCod} +\var{coeCod} & \tp \prod_{f \tp A \to X} +\var{coe}\ p_{\var{cod}}\ f \equiv \iota \lll f +\end{align} +% +I will give the proof of the first theorem here, the second one is analogous. +% +\begin{align*} +\var{coe}\ p_{\var{dom}}\ f + & \equiv f \lll \inv{(\var{idToIso}\ p)} && \text{lemma} \\ + & \equiv f \lll \inv{\iota} + && \text{$\var{idToIso}$ and $\var{isoToId}$ are inverses}\\ +\end{align*} +% +In the second step we use the fact that $p$ is constructed from the isomorphism +$\iota$ -- $\inv{(\var{idToIso}\ p)}$ denotes the map $B \to A$ induced by the +isomorphism $\var{idToIso}\ p \tp A \cong B$. The helper-lemma is similar to +what we're trying to prove but talks about paths rather than isomorphisms: +% +\begin{equation} +\label{eq:coeDomIso} +\prod_{f \tp \var{Arrow}\ A\ B} \prod_{p \tp A \equiv B} +\var{coe}\ p_{\var{dom}}\ f \equiv f \lll \inv{(\var{idToIso}\ p)} +\end{equation} +% +Again $p_{\var{dom}}$ denotes the path $\var{Arrow}\ A\ X \equiv +\var{Arrow}\ B\ X$ induced by $p$. To prove this statement I let $f$ and $p$ +be given and then invoke based-path-induction. The induction will be based at $A +\tp \var{Object}$, so let $\widetilde{B} \tp \Object$ and $\widetilde{p} \tp +A \equiv \widetilde{B}$ be given. The family that we perform induction over will +be: +% +$$ +\var{coe}\ {\widetilde{p}}^*\ f +\equiv +f \lll \inv{(\var{idToIso}\ \widetilde{p})} +$$ +The base-case therefore becomes: +\begin{align*} +\var{coe}\ {\widetilde{\refl}}^*\ f +& \equiv f \\ +& \equiv f \lll \var{identity} \\ +& \equiv f \lll \inv{(\var{idToIso}\ \widetilde{\refl})} +\end{align*} +% +The first step follows because reflexivity is a neutral element for coercion. +The second step is the identity law in the category. The last step has to do +with the fact that $\var{idToIso}$ is constructed by substituting according to +the supplied path and since reflexivity is also the neutral element for +substitutions we arrive at the desired expression. To close the +based-path-induction we must supply the value ``at the other''. In this case +this is simply $B \tp \Object$ and $p \tp A \equiv B$ which we have. + +And this finishes the proof of \ref{eq:coeDomIso} and thus \ref{eq:coeDom}. +% +\section{Categories} +\subsection{Opposite category} +\label{op-cat} +The first category I'll present is a pure construction on categories. Given some +category we can construct it's dual, called the opposite category. Starting with +a simple example allows us to focus on how we work with equivalences and +univalence in a very simple category where the structure of the category is +rather simple. + +Let $\bC$ be some category, we then define the opposite category +$\bC^{\var{Op}}$. It has the same objects, but the type of arrows are flipped, +that is to say an arrow from $A$ to $B$ in the opposite category corresponds to +an arrow from $B$ to $A$ in the underlying category. The identity arrow is the +same as the one in the underlying category (they have the same type). Function +composition will be reverse function composition from the underlying category. + +I'll refer to things in terms of the underlying category, unless they have an +over-bar. So e.g. $\idToIso$ is a function in the underlying category and the +corresponding thing is denoted $\wideoverbar{\idToIso}$ in the opposite +category. + +Showing that this forms a pre-category is rather straightforward. +% +$$ +h \rrr (g \rrr f) \equiv h \rrr g \rrr f +$$ +% +Since $\rrr$ is reverse function composition this is just the symmetric version +of associativity. +% +$$ +\var{identity} \rrr f \equiv f \x f \rrr identity \equiv f +$$ +% +This is just the swapped version of identity. + +Finally, that the arrows form sets just follows by flipping the order of the +arguments. Or in other words; since $\Arrow\ A\ B$ is a set for all $A\;B \tp +\Object$ then so is $Arrow\ B\ A$. + +Now, to show that this category is univalent is not as straight-forward. Luckily +section \ref{sec:equiv} gave us some tools to work with equivalences. We saw +that we can prove this category univalent by giving an inverse to +$\wideoverbar{\idToIso} \tp (A \equiv B) \to (A \wideoverbar{\approxeq} B)$. +From the original category we have that $\idToIso \tp (A \equiv B) \to (A \cong +B)$ is an isomorphism. Let us denote it's inverse with $\isoToId \tp (A +\approxeq B) \to (A \equiv B)$. If we squint we can see what we need is a way to +go between $\wideoverbar{\approxeq}$ and $\approxeq$. + +An inhabitant of $A \approxeq B$ is simply an arrow $f \tp \var{Arrow}\ A\ B$ +and it's inverse $g \tp \var{Arrow}\ B\ A$. In the opposite category $g$ will +play the role of the isomorphism and $f$ will be the inverse. Similarly we can +go in the opposite direction. I name these maps $\var{shuffle} \tp (A \approxeq +B) \to (A \wideoverbar{\approxeq} B)$ and $\var{shuffle}^{-1} \tp (A +\wideoverbar{\approxeq} B) \to (A \approxeq B)$ respectively. + +As the inverse of $\wideoverbar{\idToIso}$ I will pick $\wideoverbar{\isoToId} +\defeq \isoToId \comp \var{shuffle}$. The proof that they are inverses go as +follows: +% +\begin{align*} +\wideoverbar{\isoToId} \comp \wideoverbar{\idToIso} & = +\isoToId \comp \var{shuffle} \comp \wideoverbar{\idToIso} +\\ +%% ≡⟨ cong (λ φ → φ x) (cong (λ φ → η ⊙ shuffle ⊙ φ) (funExt lem)) ⟩ \\ +% +& \equiv +\isoToId \comp \var{shuffle} \comp \inv{\var{shuffle}} \comp \idToIso +&& \text{lemma} \\ +%% ≡⟨⟩ \\ +& \equiv +\isoToId \comp \idToIso +&& \text{$\var{shuffle}$ is an isomorphism} \\ +& \equiv +\identity +&& \text{$\isoToId$ is an isomorphism} +\end{align*} +% +The other direction is analogous. + +The lemma used in step 2 of this proof states that $\wideoverbar{idToIso} \equiv +\inv{\var{shuffle}} \comp \idToIso$. This is a rather straight-forward proof +since being-an-inverse-of is a proposition, so it suffices to show that their +first components are equal, but this holds judgmentally. + +This finished the proof that the opposite category is in fact a category. Now, +to prove that that opposite-of is an involution we must show: +% +$$ +\prod_{\bC \tp \var{Category}} \left(\bC^{\var{Op}}\right)^{\var{Op}} \equiv \bC +$$ +% +As we've seen the laws in $\left(\bC^{\var{Op}}\right)^{\var{Op}}$ get quite +involved.\footnote{We haven't even seen the full story because we've used this + `interface' for equivalences.} Luckily since being-a-category is a mere +proposition, we need not concern ourselves with this bit when proving the above. +We can use the equality principle for categories that let us prove an equality +just by giving an equality on the data-part. So, given a category $\bC$ all we +must provide is the following proof: +% +$$ +\var{raw}\ \left(\bC^{\var{Op}}\right)^{\var{Op}} \equiv \var{raw}\ \bC +$$ +% +And these are judgmentally the same. I remind the reader that the left-hand side +is constructed by flipping the arrows, which judgmentally is an involution. + +\subsection{Category of sets} +The category of sets has as objects, not types, but only those types that are +homotopic sets. This is encapsulated in Agda with the following type: +% +$$\Set \defeq \sum_{A \tp \MCU} \isSet\ A$$ +% +The more straight-forward notion of a category where the objects are types is +not a valid \mbox{(1-)category}. This stems from the fact that types in cubical +Agda types can have higher homotopic structure. + +Univalence does not follow immediately from univalence for types: +% +$$(A \equiv B) \simeq (A \simeq B)$$ +% +Because here $A\ B \tp \Type$ whereas the objects in this category have the type +$\Set$ so we cannot form the type $\var{hA} \simeq \var{hB}$ for objects +$\var{hA}\;\var{hB} \tp \Set$. In stead I show that this category +satisfies: +% +$$ +(\var{hA} \equiv \var{hB}) \simeq (\var{hA} \approxeq \var{hB}) +$$ +% +Which, as we saw in section \ref{sec:univalence}, is sufficient to show that the +category is univalent. The way that I have shown this is with a three-step +process. For objects $(A, s_A)\; (B, s_B) \tp \Set$ I show the following chain +of equivalences: +% +\begin{align*} +((A, s_A) \equiv (B, s_B)) + & \simeq (A \equiv B) && \ref{eq:equivPropSig} \\ + & \simeq (A \simeq B) && \text{Univalence} \\ + & \simeq ((A, s_A) \approxeq (B, s_B)) && \text{\ref{eq:equivSig} and \ref{eq:equivIso}} +\end{align*} + +And since $\simeq$ is an equivalence relation we can chain these equivalences +together. Step one will be proven with the following lemma: +% +\begin{align} + \label{eq:equivPropSig} +\left(\prod_{a \tp A} \isProp (P\ a)\right) \to \prod_{x\;y \tp \sum_{a \tp A} P\ a} (x \equiv y) \simeq (\fst\ x \equiv \fst\ y) +\end{align} +% +The lemma states that for pairs whose second component are mere propositions +equality is equivalent to equality of the first components. In this case the +type-family $P$ is $\isSet$ which itself is a proposition for any type $A \tp +\Type$. Step two is univalence. Step three will be proven with the following +lemma: +% +\begin{align} + \label{eq:equivSig} +\prod_{a \tp A} \left( P\ a \simeq Q\ a \right) \to \sum_{a \tp A} P\ a \simeq \sum_{a \tp A} Q\ a +\end{align} +% +Which says that if two type-families are equivalent at all points, then pairs +with identical first components and these families as second components will +also be equivalent. For our purposes $P \defeq \isEquiv\ A\ B$ and $Q \defeq +\var{Isomorphism}$. So we must finally prove: +% +\begin{align} + \label{eq:equivIso} +\prod_{f \tp A \to B} \left( \isEquiv\ A\ B\ f \simeq \var{Isomorphism}\ f \right) +\end{align} + +First, lets prove \ref{eq:equivPropSig}: Let $propP \tp \prod_{a \tp A} \isProp (P\ a)$ and $x\;y \tp \sum_{a \tp A} P\ a$ be given. Because +of $\var{fromIsomorphism}$ it suffices to give an isomorphism between +$x \equiv y$ and $\fst\ x \equiv \fst\ y$: +% +%% FIXME: Too much alignement? +\begin{equation*} +\begin{aligned} + f & \defeq \congruence\ \fst + && \tp x \equiv y && \to \fst\ x \equiv \fst\ y \\ + g & \defeq \var{lemSig}\ \var{propP}\ x\ y + && \tp \fst\ x \equiv \fst\ y && \to x \equiv y +\end{aligned} +\end{equation*} +% +\TODO{Is it confusing that I use point-free style here?} Here $\var{lemSig}$ is +a lemma that says that if the second component of a pair is a proposition, it +suffices to give a path between its first components to construct an equality of +the two pairs: +% +\begin{align*} +\var{lemSig} \tp \left( \prod_{x \tp A} \isProp\ (B\ x) \right) \to +\prod_{u\; v \tp \sum_{a \tp A} B\ a} + \left( \fst\ u \equiv \fst\ v \right) \to u \equiv v +\end{align*} +% +The proof that these are indeed inverses has been omitted. \TODO{Do I really + want to omit it?}\QED + +Now to prove \ref{eq:equivSig}: Let $e \tp \prod_{a \tp A} \left( P\ a \simeq +Q\ a \right)$ be given. To prove the equivalence, it suffices to give an +isomorphism between $\sum_{a \tp A} P\ a$ and $\sum_{a \tp A} Q\ a$, but since +they have identical first components it suffices to give an isomorphism between +$P\ a$ and $Q\ a$ for all $a \tp A$. This is exactly what we can get from +the equivalence $e$.\QED + +Lastly we prove \ref{eq:equivIso}. Let $f \tp A \to B$ be given. For the maps we +choose: +% +\begin{align*} +\var{toIso} + & \tp \isEquiv\ f \to \var{Isomorphism}\ f \\ +\var{fromIso} + & \tp \var{Isomorphism}\ f \to \isEquiv\ f +\end{align*} +% +As mentioned in section \ref{sec:equiv}. These maps are not in general inverses +of each other. In stead, we will use the fact that $A$ and $B$ are sets. The first thing we must prove is: +% +\begin{align*} + \var{fromIso} \comp \var{toIso} \equiv \identity_{\isEquiv\ f} +\end{align*} +% +For this we can use the fact that being-an-equivalence is a mere proposition. +For the other direction: +% +\begin{align*} + \var{toIso} \comp \var{fromIso} \equiv \identity_{\var{Isomorphism}\ f} +\end{align*} +% +We will show that $\var{Isomorphism}\ f$ is also a mere proposition. To this +end, let $X\;Y \tp \var{Isomorphism}\ f$ be given. Name the maps $x\;y \tp B +\to A$ respectively. Now, the proof that $X$ and $Y$ are the same is a pair of +paths: $p \tp x \equiv y$ and $\Path\ (\lambda\; i \to +\var{AreInverses}\ f\ (p\ i))\ \mathcal{X}\ \mathcal{Y}$ where $\mathcal{X}$ +and $\mathcal{Y}$ denotes the witnesses that $x$ (respectively $y$) is an +inverse to $f$. $p$ is inhabited by: +% +\begin{align*} + x + & \equiv x \comp \identity \\ + & \equiv x \comp (f \comp y) + && \text{$y$ is an inverse to $f$} \\ + & \equiv (x \comp f) \comp y \\ + & \equiv \identity \comp y + && \text{$x$ is an inverse to $f$} \\ + & \equiv y +\end{align*} +% +For the other (dependent) path we can prove that being-an-inverse-of is a +proposition and then use $\lemPropF$. So we prove the generalization: +% +\begin{align} +\label{eq:propAreInversesGen} +\prod_{g \tp B \to A} \isProp\ (\var{AreInverses}\ f\ g) +\end{align} +% +But $\var{AreInverses}\ f\ g$ is a pair of equations on arrows, so we use +$\propSig$ and the fact that both $A$ and $B$ are sets to close this proof. + +\subsection{Category of 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. + +Furthermore I provide some helpful lemmas about this raw category. For instance +I have shown what would be the exponential object in such a category. + +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. + +\section{Products} +In the following I'll demonstrate a technique for using categories to prove +properties. The goal in this section is to show that products are propositions: +% +$$ +\prod_{\bC \tp \Category} \prod_{A\;B \tp \Object} \isProp\ (\var{Product}\ \bC\ A\ B) +$$ +% +Where $\var{Product}\ \bC\ A\ B$ denotes the type of products of objects $A$ +and $B$ in the category $\bC$. I do this by constructing a category whose +terminal objects are equivalent to products in $\bC$, and since terminal objects +are propositional in a proper category and equivalences preserve homotopy level, +then we know that products also are propositions. But before we get to that, +let's recall the definition of products. + +\subsection{Definition of products} +Given a category $\bC$ and two objects $A$ and $B$ in $\bC$ we define the +product (object) of $A$ and $B$ to be an object $A \x B$ in $\bC$ and two arrows +$\pi_1 \tp A \x B \to A$ and $\pi_2 \tp A \x B \to B$ called the projections of +the product. The projections must satisfy the following property: + +For all $X \tp Object$, $f \tp \Arrow\ X\ A$ and $g \tp \Arrow\ X\ B$ we have +that there exists a unique arrow $\pi \tp \Arrow\ X\ (A \x B)$ satisfying +% +\begin{align} +\label{eq:umpProduct} +%% \prod_{X \tp Object} \prod_{f \tp \Arrow\ X\ A} \prod_{g \tp \Arrow\ X\ B}\\ +%% \uexists_{f \x g \tp \Arrow\ X\ (A \x B)} +\pi_1 \lll \pi \equiv f \x \pi_2 \lll \pi \equiv g +\end{align} +% +$\pi$ is called the product (arrow) of $f$ and $g$. + +\subsection{Pair category} + +\newcommand\pairA{\mathcal{A}} +\newcommand\pairB{\mathcal{B}} +Given a base category $\bC$ and two objects in this category $\pairA$ and +$\pairB$ we can construct the ``pair category'': \TODO{This is a working title, + it's nice to have a name for this thing to refer back to} + +The type of objects in this category will be an object in the underlying +category, $X$, and two arrows (also from the underlying category) +$\Arrow\ X\ \pairA$ and $\Arrow\ X\ \pairB$. + +\newcommand\pairf{\ensuremath{f}} +\newcommand\pairFst{\mathcal{\pi_1}} +\newcommand\pairSnd{\mathcal{\pi_2}} + +An arrow between objects $A ,\ a_0 ,\ a_1$ and $B ,\ b_0 ,\ b_1$ in this +category will consist of an arrow from the underlying category $\pairf \tp +\Arrow\ A\ B$ satisfying: +% +\begin{align} +\label{eq:pairArrowLaw} +b_0 \lll f \equiv a_0 \x +b_1 \lll f \equiv a_1 +\end{align} + +The identity morphism is the identity morphism from the underlying category. +This choice satisfies \ref{eq:pairArrowLaw} because of the right-identity law +from the underlying category. + +For composition of arrows $f \tp \Arrow\ A\ B$ and $g \tp \Arrow\ B\ C$ we +choose $g \lll f$ and we must now verify that it satisfies +\ref{eq:pairArrowLaw}: +% +\begin{align*} + c_0 \lll (f \lll g) + & \equiv + (c_0 \lll f) \lll g + && \text{Associativity} \\ + & \equiv + b_0 \lll g + && \text{$f$ satisfies \ref{eq:pairArrowLaw}} \\ + & \equiv + a_0 + && \text{$g$ satisfies \ref{eq:pairArrowLaw}} \\ +\end{align*} +% +Now we must verify the category-laws. For all the laws we will follow the +pattern of using the law from the underlying category, and that the type of +arrows form a set. For instance, to prove associativity we must prove that +% +\begin{align} +\label{eq:productAssoc} +\overline{h} \lll (\overline{g} \lll \overline{f}) +\equiv +(\overline{h} \lll \overline{g}) \lll \overline{f} +\end{align} +% +Here $\lll$ refers to the `embellished' composition and $\overline{f}$, +$\overline{g}$ and $\overline{h}$ are triples consisting of arrows from the +underlying category ($f$, $g$ and $h$) and a pair of witnesses to +\ref{eq:pairArrowLaw}. +%% Luckily those winesses are paths in the hom-set of the +%% underlying category which is a set, so these are mere propositions. +The proof obligations is consists of two things. The first one is: +% +\begin{align} +\label{eq:productAssocUnderlying} +h \lll (g \lll f) +\equiv +(h \lll g) \lll f +\end{align} +% +And the other proof obligation is that the witness to \ref{eq:pairArrowLaw} for +the left-hand-side and the right-hand-side are the same. + +The proof of the first goal comes directly from the underlying category. The +type of the second goal is very complicated. I will not write it out in full +here, but it suffices to show the type of the path-space. Note that the arrows +in \ref{eq:productAssoc} are arrows from $\mathcal{A} = (A , a_{\pairA} , +a_{\pairB})$ to $\mathcal{D} = (D , d_{\pairA} , d_{\pairB})$ where +$a_{\pairA}$, $a_{\pairB}$, $d_{\pairA}$ and $d_{\pairB}$ are arrows in the +underlying category. Given that $p$ is the chosen proof of +\ref{eq:productAssocUnderlying} we then have that the witness to +\ref{eq:pairArrowLaw} vary over the type: +% +\begin{align} +\label{eq:productPath} +λ\ i → d_{\pairA} \lll p\ i ≡ 2 a_{\pairA} × d_{\pairB} \lll p\ i ≡ a_{\pairB} +\end{align} +% +And these paths are in the type of the hom-set of the underlying category, so +they are mere propositions. We cannot apply the fact that arrows in $\bC$ are +sets directly, however, since $\isSet$ only talks about non-dependent paths, in +stead we generalize \ref{eq:productPath} to: +% +\begin{align} +\label{eq:productEqPrinc} +\prod_{f \tp \Arrow\ X\ Y} \isProp\ \left( y_{\pairA} \lll f ≡ x_{\pairA} × y_{\pairB} \lll f ≡ x_{\pairB} \right) +\end{align} +% +For all objects $X , x_{\pairA} , x_{\pairB}$ and $Y , y_{\pairA} , y_{\pairB}$, +but this follows from pairs preserving homotopical structure and arrows in the +underlying category being sets. This gives us an equality principle for arrows +in this category that says that to prove two arrows $f, f_0, f_1$ and $g, g_0, +g_1$ equal it suffices to give a proof that $f$ and $g$ are equal. +%% % +%% $$ +%% \prod_{(f, f_0, f_1)\; (g,g_0,g_1) \tp \Arrow\ X\ Y} f \equiv g \to (f, f_0, f_1) \equiv (g,g_0,g_1) +%% $$ +%% % +And thus we have proven \ref{eq:productAssoc} simply with +\ref{eq:productAssocUnderlying}. + +Now we must prove that arrows form a set: +% +$$ +\isSet\ (\Arrow\ \mathcal{X}\ \mathcal{Y}) +$$ +% +Since pairs preserve homotopical structure this reduces to: +% +$$ +\isSet\ (\Arrow_{\bC}\ X\ Y) +$$ +% +Which holds. And +% +$$ +\prod_{f \tp \Arrow\ X\ Y} +\isSet\ \left( y_{\pairA} \lll f ≡ x_{\pairA} + × y_{\pairB} \lll f ≡ x_{\pairB} + \right) +$$ +% +This we get from \ref{eq:productEqPrinc} and the fact that homotopical structure +is cumulative. + +This finishes the proof that this is a valid pre-category. + +\subsubsection{Univalence} +To prove that this is a proper category it must be shown that it is univalent. +That is, for any two objects $\mathcal{X} = (X, x_{\mathcal{A}} , x_{\mathcal{B}})$ +and $\mathcal{Y} = Y, y_{\mathcal{A}}, y_{\mathcal{B}}$ I will show: +% +\begin{align} +(\mathcal{X} \equiv \mathcal{Y}) \cong (\mathcal{X} \approxeq \mathcal{Y}) +\end{align} + +I do this by showing that the following sequence of types are isomorphic. + +The first type is: +% +\begin{align} +\label{eq:univ-0} +(X , x_{\mathcal{A}} , x_{\mathcal{B}}) ≡ (Y , y_{\mathcal{A}} , y_{\mathcal{B}}) +\end{align} +% +The next types will be the triple: +% +\begin{align} +\label{eq:univ-1} +\begin{split} +p \tp & X \equiv Y \\ +& \Path\ (λ i → \Arrow\ (p\ i)\ \mathcal{A})\ x_{\mathcal{A}}\ y_{\mathcal{A}} \\ +& \Path\ (λ i → \Arrow\ (p\ i)\ \mathcal{B})\ x_{\mathcal{B}}\ y_{\mathcal{B}} +\end{split} +%% \end{split} +\end{align} + +The next type is very similar, but in stead of a path we will have an +isomorphism, and create a path from this: +% +\begin{align} +\label{eq:univ-2} +\begin{split} +\var{iso} \tp & X \cong Y \\ +& \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ \mathcal{A})\ x_{\mathcal{A}}\ y_{\mathcal{A}} \\ +& \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ \mathcal{B})\ x_{\mathcal{B}}\ y_{\mathcal{B}} +\end{split} +\end{align} +% +Where $\widetilde{p} \defeq \var{isoToId}\ \var{iso} \tp X \equiv Y$. + +Finally we have the type: +% +\begin{align} +\label{eq:univ-3} +(X , x_{\mathcal{A}} , x_{\mathcal{B}}) ≊ (Y , y_{\mathcal{A}} , y_{\mathcal{B}}) +\end{align} + +\emph{Proposition} \ref{eq:univ-0} is isomorphic to \ref{eq:univ-1}: This is +just an application of the fact that a path between two pairs $a_0, a_1$ and +$b_0, b_1$ corresponds to a pair of paths between $a_0,b_0$ and $a_1,b_1$ (check +the implementation for the details). + +\emph{Proposition} \ref{eq:univ-1} is isomorphic to \ref{eq:univ-2}: +\TODO{Super complicated} + +\emph{Proposition} \ref{eq:univ-2} is isomorphic to \ref{eq:univ-3}: For this I +will show two corollaries of \ref{eq:coeCod}: For an isomorphism $(\iota, +\inv{\iota}, \var{inv}) \tp A \cong B$, arrows $f \tp \Arrow\ A\ X$, $g \tp +\Arrow\ B\ X$ and a heterogeneous path between them, $q \tp \Path\ (\lambda i +\to p_{\var{dom}}\ i)\ f\ g$, where $p_{\var{dom}} \tp \Arrow\ A\ X \equiv +\Arrow\ B\ X$ is a path induced by $\var{iso}$, we have the following two +results +% +\begin{align} +\label{eq:domain-twist-0} +f & \equiv g \lll \iota \\ +\label{eq:domain-twist-1} +g & \equiv f \lll \inv{\iota} +\end{align} +% +Proof: \TODO{\ldots} + +Now we can prove the equivalence in the following way: Given $(f, \inv{f}, +\var{inv}_f) \tp X \cong Y$ and two heterogeneous paths +% +\begin{align*} +p_{\mathcal{A}} & \tp \Path\ (\lambda i \to p_{\var{dom}}\ i)\ x_{\mathcal{A}}\ y_{\mathcal{A}}\\ +% +q_{\mathcal{B}} & \tp \Path\ (\lambda i \to p_{\var{dom}}\ i)\ x_{\mathcal{B}}\ y_{\mathcal{B}} +\end{align*} +% +all as in \ref{eq:univ-2}. I use $p_{\var{dom}}$ here again to mean the path +induced by the isomorphism $f, \inv{f}$. I must now construct an isomorphism +$(X, x_{\mathcal{A}}, x_{\mathcal{B}}) \approxeq (Y, y_{\mathcal{A}}, y_{\mathcal{B}})$ +as in \ref{eq:univ-3}. That is, an isomorphism in the present category. I remind +the reader that such a gadget is a triple. The first component shall be: +% +\begin{align} +f \tp \Arrow\ X\ Y +\end{align} +% +To show that this choice fits the bill I must now verify that it satisfies +\ref{eq:pairArrowLaw}, which in this case becomes: +% +\begin{align} +y_{\mathcal{A}} \lll f ≡ x_{\mathcal{A}} × y_{\mathcal{B}} \lll f ≡ x_{\mathcal{B}} +\end{align} +% +Which, since $f$ is an isomorphism and $p_{\mathcal{A}}$ (resp. $p_{\mathcal{B}}$) +is a path varying according to a path constructed from this isomorphism, this is +exactly what \ref{eq:domain-twist-0} gives us. +% +The other direction is quite analogous. We choose $\inv{f}$ as the morphism and +prove that it satisfies \ref{eq:pairArrowLaw} with \ref{eq:domain-twist-1}. + +We must now show that this choice of arrows indeed form an isomorphism. Our +equality principle for arrows in this category (\ref{eq:productEqPrinc}) gives +us that it suffices to show that $f$ and $\inv{f}$, this is exactly +$\var{inv}_f$. + +This concludes the first direction of the isomorphism that we're constructing. +For the other direction we're given just given the isomorphism +% +$$ +(f, \inv{f}, \var{inv}_f) +\tp +(X, x_{\mathcal{A}}, x_{\mathcal{B}}) \approxeq (Y, y_{\mathcal{A}}, y_{\mathcal{B}}) +$$ +% +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 +$$ +% +This gives rise to the following paths: +% +\begin{align} +\begin{split} +\widetilde{p} & \tp X \equiv Y \\ +\widetilde{p}_{\mathcal{A}} & \tp \Arrow\ X\ \mathcal{A} \equiv \Arrow\ Y\ \mathcal{A} \\ +\widetilde{p}_{\mathcal{B}} & \tp \Arrow\ X\ \mathcal{B} \equiv \Arrow\ Y\ \mathcal{B} +\end{split} +\end{align} +% +It then remains to construct the two paths: +% +\begin{align} +\begin{split} +\label{eq:product-paths} +& \Path\ (λ i → \widetilde{p}_{\mathcal{A}}\ i)\ x_{\mathcal{A}}\ y_{\mathcal{A}}\\ +& \Path\ (λ i → \widetilde{p}_{\mathcal{B}}\ i)\ x_{\mathcal{B}}\ y_{\mathcal{B}} +\end{split} +\end{align} +% +This is achieved with the following lemma: +% +\begin{align} +\prod_{a \tp A} \prod_{b \tp B} \prod_{q \tp A \equiv B} \var{coe}\ q\ a ≡ b → +\Path\ (λ i → q\ i)\ a\ b +\end{align} +% +Which is used without proof. See the implementation for the details. + +\ref{eq:product-paths} is the proven with the propositions: +% +\begin{align} +\begin{split} +\label{eq:product-paths} +\var{coe}\ \widetilde{p}_{\mathcal{A}}\ x_{\mathcal{A}} ≡ y_{\mathcal{A}}\\ +\var{coe}\ \widetilde{p}_{\mathcal{B}}\ x_{\mathcal{B}} ≡ y_{\mathcal{B}} +\end{split} +\end{align} +% +The proof of the first one is: +% +\begin{align*} + \var{coe}\ \widetilde{p}_{\mathcal{A}}\ x_{\mathcal{A}} + & ≡ x_{\mathcal{A}} \lll \fst\ \inv{f} && \text{$\var{coeDom}$ and the isomorphism $f, \inv{f}$} \\ + & ≡ y_{\mathcal{A}} && \text{\ref{eq:pairArrowLaw} for $\inv{f}$} +\end{align*} +% +We have now constructed the maps between \ref{eq:univ-0} and \ref{eq:univ-1}. It +remains to show that they are inverses of each other. To cut a long story short, +the proof uses the fact that isomorphism-of is propositional and that arrows (in +both categories) are sets. The reader is referred to the implementation for the +gory details. +% +\subsection{Propositionality of products} +% +Now that we've constructed the ``pair category'' I'll demonstrate how to use +this to prove that products are propositional. I will do this by showing that +terminal objects in this category are equivalent to products: +% +\begin{align} +\var{Terminal} ≃ \var{Product}\ ℂ\ \mathcal{A}\ \mathcal{B} +\end{align} +% +And as always we do this by constructing an isomorphism: +% +In the direction $\var{Terminal} → \var{Product}\ ℂ\ \mathcal{A}\ \mathcal{B}$ +we're given a terminal object $X, x_𝒜, x_ℬ$. $X$ Will be the product-object and +$x_𝒜, x_ℬ$ will be the product arrows, so it just remains to verify that this is +indeed a product. That is, for an object $Y$ and two arrows $y_𝒜 \tp +\Arrow\ Y\ 𝒜$, $y_ℬ\ \Arrow\ Y\ ℬ$ we must find a unique arrow $f \tp +\Arrow\ Y\ X$ satisfying: +% +\begin{align} +\label{eq:pairCondRev} +\begin{split} + x_𝒜 \lll f & ≡ y_𝒜 \\ + x_ℬ \lll f & ≡ y_ℬ +\end{split} +\end{align} +% +Since $X, x_𝒜, x_ℬ$ is a terminal object there is a \emph{unique} arrow from +this object to any other object, so also $Y, y_𝒜, y_ℬ$ in particular (which is +also an object in the pair category). The arrow we will play the role of $f$ and +it immediately satisfies \ref{eq:pairCondRev}. Any other arrow satisfying these +conditions will be equal since $f$ is unique. + +For the other direction we are now given a product $X, x_𝒜, x_ℬ$. Again this +will be the terminal object. So now it remains that for any other object there +is a unique arrow from that object into $X, x_𝒜, x_ℬ$. Let $Y, y_𝒜, y_ℬ$ be +another object. As the arrow $\Arrow\ Y\ X$ we choose the product-arrow $y_𝒜 \x +y_ℬ$. Since this is a product-arrow it satisfies \ref{eq:pairCondRev}. Let us +name the witness to this $\phi_{y_𝒜 \x y_ℬ}$. So we have picked as our center of +contraction $y_𝒜 \x y_ℬ , \phi_{y_𝒜 \x y_ℬ}$ we must now show that it is +contractible. So let $f \tp \Arrow\ X\ Y$ and $\phi_f$ be given (here $\phi_f$ +is the proof that $f$ satisfies \ref{eq:pairCondRev}). The proof will be a pair +of proofs: +% +\begin{alignat}{3} + p \tp & \Path\ (\lambda i \to \Arrow\ X\ Y)\quad + && f\quad && y_𝒜 \x y_ℬ \\ + & \Path\ (\lambda i \to \Phi\ (p\ i))\quad + && \phi_f\quad && \phi_{y_𝒜 \x y_ℬ} +\end{alignat} +% +Here $\Phi$ is given as: +$$ +\prod_{f \tp \Arrow\ Y\ X} + x_𝒜 \lll f ≡ y_𝒜 +× x_ℬ \lll f ≡ y_ℬ +$$ +% +$p$ follows from the universal property of $y_𝒜 \x y_ℬ$. For the latter we will +again use the same trick we did in \ref{eq:propAreInversesGen} and prove this +more general result: +% +$$ +\prod_{f \tp \Arrow\ Y\ X} \isProp\ ( + x_𝒜 \lll f ≡ y_𝒜 +× x_ℬ \lll f ≡ y_ℬ +) +$$ +% +Which follows from arrows being sets and pairs preserving such. Thus we can +close the final proof with an application of $\lemPropF$. + +This concludes the proof $\var{Terminal} ≃ +\var{Product}\ ℂ\ \mathcal{A}\ \mathcal{B}$ and since we have that equivalences +preserve homotopic levels along with \ref{eq:termProp} we get our final result. +That in any category: +% +\begin{align} +\prod_{A\ B \tp \Object} \isProp\ (\var{Product}\ \bC\ A\ B) +\end{align} +% +\section{Monads} +In this section I present two formulations of monads. The two representations +are referred to as the monoidal- and Kleisli- representation respectively or +simply monoidal monads and Kleisli monads for short. We then show that the two +formulations are equivalent, which due to univalence gives us a path between the +two types. + +Let a category $\bC$ be given. In the remainder of this sections all objects and +arrows will implicitly refer to objects and arrows in this category. +% +\subsection{Monoidal formulation} +The monoidal formulation of monads consists of the following data: +% +\begin{align} +\label{eq:monad-monoidal-data} +\begin{split} + \EndoR & \tp \Endo ℂ \\ + \var{pure} & \tp \NT{\EndoR^0}{\EndoR} \\ + \var{join} & \tp \NT{\EndoR^2}{\EndoR} +\end{split} +\end{align} +% +Here $\NTsym$ denotes natural transformations, the super-script in $\EndoR^2$ +Denotes the composition of $\EndoR$ with itself. By the same token $\EndoR^0$ is +a curious way of denoting the identity functor. This notation has been chosen +for didactic purposes. + +Denote the arrow-map of $\EndoR$ as $\fmap$, then this data must satisfy the +following laws: +% +\begin{align} +\label{eq:monad-monoidal-laws} +\begin{split} + \var{join} \lll \fmap\ \var{join} + & ≡ \var{join} \lll \var{join}\ \fmap \\ + \var{join} \lll \var{pure}\ \fmap & ≡ \identity \\ + \var{join} \lll \fmap\ \var{pure} & ≡ \identity +\end{split} +\end{align} +% +The implicit arguments to the arrows above have been left out and the objects +they range over are universally quantified. + +\subsection{Kleisli formulation} +% +The Kleisli-formulation consists of the following data: +% +\begin{align} +\label{eq:monad-kleisli-data} +\begin{split} + \EndoR & \tp \Object → \Object \\ + \pure & \tp % \prod_{X \tp Object} + \Arrow\ X\ (\EndoR\ X) \\ + \bind & \tp % \prod_{X\;Y \tp Object} → \Arrow\ X\ (\EndoR\ Y) + \Arrow\ (\EndoR\ X)\ (\EndoR\ Y) +\end{split} +\end{align} +% +The objects $X$ and $Y$ are implicitly universally quantified. + +It's interesting to note here that this formulation does not talk about natural +transformations or other such constructs from category theory. All we have here +is a regular maps on objects and a pair of arrows. +% +This data must satisfy: +% +\begin{align} +\label{eq:monad-monoidal-laws} +\begin{split} + \bind\ \pure & ≡ \identity_{\EndoR\ X} + \\ + % \prod_{f \tp \Arrow\ X\ (\EndoR\ Y)} + \pure \fish f & ≡ f + \\ + % \prod_{\substack{g \tp \Arrow\ Y\ (\EndoR\ Z)\\f \tp \Arrow\ X\ (\EndoR\ Y)}} + (\bind\ f) \rrr (\bind\ g) & ≡ \bind\ (f \fish g) +\end{split} +\end{align} +% +Here likewise the arrows $f \tp \Arrow\ X\ (\EndoR\ Y)$ and $g \tp +\Arrow\ Y\ (\EndoR\ Z)$ are universally quantified (as well as the objects they +range over). $\fish$ is the Kleisli-arrow which is defined as $f \fish g \defeq +f \rrr (\bind\ g)$ . (\TODO{Better way to typeset $\fish$?}) + +\subsection{Equivalence of formulations} +% +In my implementation I proceed to show how the one formulation gives rise to +the other and vice-versa. For the present purpose I will briefly sketch some +parts of this construction: + +The notation I have chosen here in the report +overloads e.g. $\pure$ to both refer to a natural transformation and an arrow. +This is of course not a coincidence as the arrow in the Kleisli formulation +shall correspond exactly to the map on arrows from the natural transformation +called $\pure$. + +In the monoidal formulation we can define $\bind$: +% +\begin{align} +\bind \defeq \join \lll \fmap\ f +\end{align} +% +And likewise in the Kleisli formulation we can define $\join$: +% +\begin{align} +\join \defeq \bind\ \identity +\end{align} +% +It now remains to show that we can prove the various laws given this choice. I +refer the reader to my implementation for the details. diff --git a/doc/introduction.tex b/doc/introduction.tex new file mode 100644 index 0000000..12ad3b3 --- /dev/null +++ b/doc/introduction.tex @@ -0,0 +1,205 @@ +\chapter{Introduction} +Functional extensionality and univalence is not expressible in +\nomen{Intensional Martin Löf Type Theory} (ITT). This poses a severe limitation +on both i. what is \emph{provable} and ii. the \emph{re-usability} 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}, \cite{cubical-agda}) that allows us to work in such a ``cubical +setting''. This thesis will explore the usefulness of this extension in the +context of category theory. +% +\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} +Consider the functions: +% +\begin{multicols}{2} + \noindent + \begin{equation*} + f \defeq (n \tp \bN) \mapsto (0 + n \tp \bN) + \end{equation*} + \begin{equation*} + g \defeq (n \tp \bN) \mapsto (n + 0 \tp \bN) + \end{equation*} +\end{multicols} +% +$n + 0$ is \nomen{definitionally} equal to $n$, which we write as $n + 0 = n$. +This is also called \nomen{judgmental} equality. 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*} + + & \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$. $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, which we write as $n + 0 \equiv n$. 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{point-wise equality}, where the \emph{points} of a function refers +to it's arguments. + +In the context of category theory functional extensionality is e.g. needed to +show 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$) thus 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 prove $\idFun \comp g +\equiv g$ and thus close the goal. +% +\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 have the same shape (Greek; \nomen{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 +\nomen{equivalent} types. I will return to the definition of equivalence later +in section \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 common to identify isomorphic structures +and 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. + +\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. Just as a first reference see this +question on Math Overflow: \cite{mo-formalizations}. Notably these +implementations of category theory in Agda: +% +\begin{itemize} +\item + \url{https://github.com/copumpkin/categories} + + A formalization in Agda using the setoid approach +\item + \url{https://github.com/pcapriotti/agda-categories} + + A formalization in Agda with univalence and functional extensionality as + postulates. +\item + \url{https://github.com/HoTT/HoTT/tree/master/theories/Categories} + + A formalization in Coq in the homotopic setting +\item + \url{https://github.com/mortberg/cubicaltt} + + A formalization in CubicalTT - a language designed for cubical-type-theory. + Formalizes many different things, but only a few concepts from category + theory. + +\end{itemize} +% +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 and to try and +compare some aspects of this formalization with the existing ones.\TODO{How can + I live up to this?} + +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} (\TODO{Pageno!} \cite{huber-2016}). 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$; $e = \mathit{suc}^n\ 0$. Without canonicity +terms in the language can get ``stuck'' -- meaning that they do not reduce to a +canonical form. + +Another approach is to use the \emph{setoid interpretation} of type theory +(\cite{hofmann-1995,huber-2016}). With this approach one works with +\nomen{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. This approach has other drawbacks; it does not satisfy +all propositional equalities of type theory (\TODO{Citation needed}), is +cumbersome to work with in practice (\cite[p. 4]{huber-2016}) and makes +equational proofs less reusable since equational proofs $a \sim_{X} b$ are +inherently `local' to the extensional set $(X , \sim)$. + +\section{Conventions} +\TODO{Talk a bit about terminology. Find a good place to stuff this little + section.} + +In the remainder of this paper I will use the term \nomen{Type} to describe -- +well, types. Thereby diverging from the notation in Agda where the keyword +\texttt{Set} refers to types. \nomen{Set} on the other hand shall refer to the +homotopical notion of a set. I will also leave all universe levels implicit. + +And I use the term \nomen{arrow} to refer to morphisms in a category, whereas +the terms morphism, map or function shall be reserved for talking about +type-theoretic functions; i.e. functions in Agda. + +$\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{center} +\begin{tabular}{ c c c } +Name & Agda & Notation \\ +\hline +\nomen{Type} & \texttt{Set} & $\Type$ \\ +\nomen{Set} & \texttt{Σ Set IsSet} & $\Set$ \\ +Function, morphism, map & \texttt{A → B} & $A → B$ \\ +Dependent- ditto & \texttt{(a : A) → B} & $∏_{a \tp A} B$ \\ +\nomen{Arrow} & \texttt{Arrow A B} & $\Arrow\ A\ B$ \\ +\nomen{Object} & \texttt{C.Object} & $̱ℂ.Object$ \\ +Definition & \texttt{=} & $̱\defeq$ \\ +Judgmental equality & \null & $̱=$ \\ +Propositional equality & \null & $̱\equiv$ +\end{tabular} +\end{center} diff --git a/doc/isomorphism.png b/doc/isomorphism.png new file mode 100644 index 0000000..03c5a8b Binary files /dev/null and b/doc/isomorphism.png differ diff --git a/doc/macros.tex b/doc/macros.tex new file mode 100644 index 0000000..a5e03db --- /dev/null +++ b/doc/macros.tex @@ -0,0 +1,88 @@ +\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}{\mathbb{C}} +\newcommand{\bX}{\mathbb{X}} +% \newcommand{\to}{\rightarrow} +\newcommand{\mto}{\mapsto} +\newcommand{\UU}{\ensuremath{\mathcal{U}}\xspace} +\let\type\UU +\newcommand{\MCU}{\UU} +\newcommand{\nomen}[1]{\emph{#1}} +\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{\Hom}{\var{Hom}} +\newcommand{\fmap}{\var{fmap}} +\newcommand{\bind}{\var{bind}} +\newcommand{\join}{\var{join}} +\newcommand{\omap}{\var{omap}} +\newcommand{\pure}{\var{pure}} +\newcommand{\idFun}{\var{id}} +\newcommand{\Sets}{\var{Sets}} +\newcommand{\Set}{\var{Set}} +\newcommand{\hSet}{\var{hSet}} +\newcommand{\id}{\var{id}} +\newcommand{\isEquiv}{\var{isEquiv}} +\newcommand{\idToIso}{\var{idToIso}} +\newcommand{\isSet}{\var{isSet}} +\newcommand{\isContr}{\var{isContr}} +\newcommand{\isGroupoid}{\var{isGroupoid}} +\newcommand{\pathJ}{\var{pathJ}} +\newcommand\Object{\var{Object}} +\newcommand\Functor{\var{Functor}} +\newcommand\isProp{\var{isProp}} +\newcommand\propPi{\var{propPi}} +\newcommand\propSig{\var{propSig}} +\newcommand\PreCategory{\var{PreCategory}} +\newcommand\IsPreCategory{\var{IsPreCategory}} +\newcommand\isIdentity{\var{isIdentity}} +\newcommand\propIsIdentity{\var{propIsIdentity}} +\newcommand\IsCategory{\var{IsCategory}} +\newcommand\Gl{\var{\lambda}} +\newcommand\lemPropF{\var{lemPropF}} +\newcommand\isPreCategory{\var{isPreCategory}} +\newcommand\congruence{\var{cong}} +\newcommand\identity{\var{identity}} +\newcommand\isequiv{\var{isequiv}} +\newcommand\qinv{\var{qinv}} +\newcommand\fiber{\var{fiber}} +\newcommand\shuffle{\var{shuffle}} +\newcommand\Univalent{\var{Univalent}} +\newcommand\refl{\var{refl}} +\newcommand\isoToId{\var{isoToId}} +\newcommand\Isomorphism{\var{Isomorphism}} +\newcommand\rrr{\ggg} +\newcommand\fish{\mathrel{\wideoverbar{\rrr}}} +\newcommand\fst{\var{fst}} +\newcommand\snd{\var{snd}} +\newcommand\Path{\var{Path}} +\newcommand\Category{\var{Category}} +\newcommand\TODO[1]{TODO: \emph{#1}} +\newcommand*{\QED}{\hfill\ensuremath{\square}}% +\newcommand\uexists{\exists!} +\newcommand\Arrow{\var{Arrow}} +\newcommand\NTsym{\var{NT}} +\newcommand\NT[2]{\NTsym\ #1\ #2} +\newcommand\Endo[1]{\var{Endo}\ #1} +\newcommand\EndoR{\mathcal{R}} diff --git a/doc/main.tex b/doc/main.tex new file mode 100644 index 0000000..917f74d --- /dev/null +++ b/doc/main.tex @@ -0,0 +1,76 @@ +\documentclass[a4paper]{report} +%% \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} +\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} +\bibliographystyle{plain} + +%% \newtheorem{prop}{Proposition} +\makeatletter +\newcommand*{\rom}[1]{\expandafter\@slowroman\romannumeral #1@} +\makeatother +\begin{document} +\myfrontmatter +\pagenumbering{roman} +\maketitle +\addtocontents{toc}{\protect\thispagestyle{empty}} +\tableofcontents +\pagenumbering{arabic} +% +\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{sources.tex} +%% \input{planning.tex} +%% \input{halftime.tex} +\end{appendices} +\end{document} diff --git a/doc/packages.tex b/doc/packages.tex new file mode 100644 index 0000000..19837af --- /dev/null +++ b/doc/packages.tex @@ -0,0 +1,87 @@ +\usepackage[utf8]{inputenc} + +\usepackage{natbib} +\usepackage[ + hidelinks, + pdfusetitle, + pdfsubject={category theory}, + pdfkeywords={type theory, homotopy theory, category theory, agda}] + {hyperref} + +\usepackage{graphicx} + +\usepackage{parskip} +\usepackage{multicol} +\usepackage{amssymb,amsmath,amsthm,stmaryrd,mathrsfs,wasysym} +\usepackage[toc,page]{appendix} +\usepackage{xspace} +\usepackage[a4paper]{geometry} + +% \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{≊}} diff --git a/proposal/planning.tex b/doc/planning.tex similarity index 99% rename from proposal/planning.tex rename to doc/planning.tex index 91d7cc6..05d7a69 100644 --- a/proposal/planning.tex +++ b/doc/planning.tex @@ -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: diff --git a/proposal/refs.bib b/doc/refs.bib similarity index 88% rename from proposal/refs.bib rename to doc/refs.bib index 93665a7..4f335ac 100644 --- a/proposal/refs.bib +++ b/doc/refs.bib @@ -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}} } \ No newline at end of file diff --git a/doc/sources.tex b/doc/sources.tex new file mode 100644 index 0000000..d270c1f --- /dev/null +++ b/doc/sources.tex @@ -0,0 +1,428 @@ +\chapter{Source code} +\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. It's provided here as a convenience. The actual sources +are the only authoritative source. Is something is not clear, please refer to +those. +\clearpage +\section{Cubical} +\label{sec:app-cubical} +\begin{figure}[h] +\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} +% +\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} diff --git a/libs/agda-stdlib b/libs/agda-stdlib index fbd8ba7..4493cf2 160000 --- a/libs/agda-stdlib +++ b/libs/agda-stdlib @@ -1 +1 @@ -Subproject commit fbd8ba7ea84c4b643fd08797b4031b18a59f561d +Subproject commit 4493cf249a1648be2ad365fe94ece337bfbcb5d9 diff --git a/libs/cubical b/libs/cubical index 5b35333..4e5d43a 160000 --- a/libs/cubical +++ b/libs/cubical @@ -1 +1 @@ -Subproject commit 5b35333dbbd8fa523e478c1cfe60657321ca38fe +Subproject commit 4e5d43a9c75286b3a8750567d75a930674d7720d diff --git a/proposal/BACKLOG.md b/proposal/BACKLOG.md deleted file mode 100644 index b889c92..0000000 --- a/proposal/BACKLOG.md +++ /dev/null @@ -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 diff --git a/proposal/chalmerstitle.sty b/proposal/chalmerstitle.sty deleted file mode 100644 index c2aa355..0000000 --- a/proposal/chalmerstitle.sty +++ /dev/null @@ -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} -} diff --git a/proposal/macros.tex b/proposal/macros.tex deleted file mode 100644 index 2653ac3..0000000 --- a/proposal/macros.tex +++ /dev/null @@ -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]}} diff --git a/proposal/proposal.tex b/proposal/proposal.tex deleted file mode 100644 index 073ecb5..0000000 --- a/proposal/proposal.tex +++ /dev/null @@ -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} diff --git a/report/.gitignore b/report/.gitignore deleted file mode 100644 index acf395a..0000000 --- a/report/.gitignore +++ /dev/null @@ -1 +0,0 @@ -cat.pdf diff --git a/report/Makefile b/report/Makefile deleted file mode 100644 index 0e61431..0000000 --- a/report/Makefile +++ /dev/null @@ -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) diff --git a/report/cat.md b/report/cat.md deleted file mode 100644 index 6119866..0000000 --- a/report/cat.md +++ /dev/null @@ -1,90 +0,0 @@ ---- -title: Formalizing category theory in Agda - Project description -date: May 27th 2017 -author: Frederik Hanghøj Iversen `` -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. - - - -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 -========== diff --git a/report/refs.bib b/report/refs.bib deleted file mode 100644 index 855fcf9..0000000 --- a/report/refs.bib +++ /dev/null @@ -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} -} \ No newline at end of file diff --git a/src/Cat/Categories/Cat.agda b/src/Cat/Categories/Cat.agda index e8a6f73..de9b2ff 100644 --- a/src/Cat/Categories/Cat.agda +++ b/src/Cat/Categories/Cat.agda @@ -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ℓ diff --git a/src/Cat/Categories/Cube.agda b/src/Cat/Categories/Cube.agda index f338343..121cb24 100644 --- a/src/Cat/Categories/Cube.agda +++ b/src/Cat/Categories/Cube.agda @@ -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 @@ -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ℂ diff --git a/src/Cat/Categories/CwF.agda b/src/Cat/Categories/CwF.agda index 45dbf2b..1a491ec 100644 --- a/src/Cat/Categories/CwF.agda +++ b/src/Cat/Categories/CwF.agda @@ -25,21 +25,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 diff --git a/src/Cat/Categories/Fam.agda b/src/Cat/Categories/Fam.agda index 5ffde56..157b3b5 100644 --- a/src/Cat/Categories/Fam.agda +++ b/src/Cat/Categories/Fam.agda @@ -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 diff --git a/src/Cat/Categories/Free.agda b/src/Cat/Categories/Free.agda index 1d262dd..b55face 100644 --- a/src/Cat/Categories/Free.agda +++ b/src/Cat/Categories/Free.agda @@ -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 _ _ diff --git a/src/Cat/Categories/Fun.agda b/src/Cat/Categories/Fun.agda index 18165d3..eb861e7 100644 --- a/src/Cat/Categories/Fun.agda +++ b/src/Cat/Categories/Fun.agda @@ -1,181 +1,218 @@ -{-# OPTIONS --allow-unsolved-metas --cubical #-} +{-# OPTIONS --allow-unsolved-metas --cubical --caching #-} module Cat.Categories.Fun where 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 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 + + U : (F : ℂ.Object → 𝔻.Object) → Set _ + U F = {A B : ℂ.Object} → ℂ [ A , B ] → 𝔻 [ F A , F B ] + + module _ + (omap : ℂ.Object → 𝔻.Object) + (p : A.omap ≡ omap) where - res : (𝔻 [ coe𝟙 b ∘ A.fmap f ]) ≡ (𝔻 [ B.fmap f ∘ coe𝟙 a ]) - res = {!!} + 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 - nat : Natural A B coe𝟙 - nat = nat' + fmapEq : PathP (λ i → U (omapEq i)) A.fmap B.fmap + fmapEq = pathJ D d B.omap omapEq B.fmap B.isFunctor iso - fromEq : NaturalTransformation A B - fromEq = coe𝟙 , nat + rawEq : A.raw ≡ B.raw + rawEq i = record { omap = omapEq i ; fmap = fmapEq 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 + 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 → ?!} , {!!} - reverse : A ≅ B → A ≡ B - reverse iso = {!!} + iso : (A ≡ B) ≅ (A ≊ B) + iso = f , g , inv - ve-re : (y : A ≅ B) → obverse (reverse y) ≡ y - ve-re = {!!} + univ : (A ≡ B) ≃ (A ≊ B) + univ = fromIsomorphism _ _ iso - re-ve : (x : A ≡ B) → reverse (obverse x) ≡ x - 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 + -- Date: Fri Apr 13 15:26:46 2018 +0200 + univalent : Univalent + univalent = univalenceFrom≃ univ - 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!} - - 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 diff --git a/src/Cat/Categories/Rel.agda b/src/Cat/Categories/Rel.agda index 5b44601..3aa4e59 100644 --- a/src/Cat/Categories/Rel.agda +++ b/src/Cat/Categories/Rel.agda @@ -1,8 +1,7 @@ {-# 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.Category @@ -153,14 +152,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 diff --git a/src/Cat/Categories/Sets.agda b/src/Cat/Categories/Sets.agda index 05c64b3..e707b55 100644 --- a/src/Cat/Categories/Sets.agda +++ b/src/Cat/Categories/Sets.agda @@ -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.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.Equivalence _⊙_ : {ℓ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 diff --git a/src/Cat/Category.agda b/src/Cat/Category.agda index 70eb654..274f94e 100644 --- a/src/Cat/Category.agda +++ b/src/Cat/Category.agda @@ -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 -- @@ -48,23 +46,25 @@ import Function record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where 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 _∘_ _>>>_ + -- infixr 8 _<<<_ + -- infixl 8 _>>>_ + infixl 10 _<<<_ _>>>_ -- | Operations on data - domain : { a b : Object } → Arrow a b → Object - domain {a = a} _ = a + domain : {a b : Object} → Arrow a b → Object + domain {a} _ = a - codomain : { a b : Object } → Arrow a b → Object + codomain : {a b : Object} → Arrow a b → Object codomain {b = b} _ = b _>>>_ : {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 +72,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 {X} f = (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 {X} f = (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 +110,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 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 - -- 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 -- - ------------ - - -- | 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₁ ∎ - - 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₁ ∎ - - iso→epi×mono : Isomorphism f → Epimorphism {X = X} f × Monomorphism {X = X} f - iso→epi×mono iso = iso→epi iso , iso→mono iso - - -- | The formulation of univalence expressed with _≃_ is trivially admissable - - -- just "forget" the equivalence. - univalent≃ : Univalent≃ - univalent≃ = _ , univalent - - -- | All projections are propositions. - module Propositionality where - propIsAssociative : isProp IsAssociative - propIsAssociative x y i = arrowsAreSets _ _ x y i - - 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 - - propArrowIsSet : isProp (∀ {A B} → isSet (Arrow A B)) - propArrowIsSet a b i = isSetIsProp a b i - - 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 - - module _ {A B : Object} {f : Arrow A B} where - isoIsProp : isProp (Isomorphism f) - isoIsProp 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' ∎ + univalenceFrom≅ : Univalent≅ → Univalent + univalenceFrom≅ x = univalenceFrom≃ $ fromIsomorphism _ _ x propUnivalent : isProp Univalent propUnivalent a b i = propPi (λ iso → propIsContr) a b i --- | Propositionality of being a category +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 + + leftIdentity : {A B : Object} {f : Arrow A B} → identity <<< f ≡ f + leftIdentity {A} {B} {f} = fst (isIdentity {A = A} {B} {f}) + + 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 {X = X} 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 {X = X} 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 {X = X} f × Monomorphism {X = X} f + iso→epi×mono iso = iso→epi iso , iso→mono iso + + propIsAssociative : isProp IsAssociative + propIsAssociative = propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl (λ _ → propPiImpl λ _ → arrowsAreSets _ _)))))) + + propIsIdentity : ∀ {f : ∀ {A} → Arrow A A} → isProp (IsIdentity f) + propIsIdentity {id} = propPiImpl (λ _ → propPiImpl λ _ → propPiImpl (λ f → + propSig (arrowsAreSets (id <<< f) f) λ _ → arrowsAreSets (f <<< id) f)) + + propArrowIsSet : isProp (∀ {A B} → isSet (Arrow A B)) + propArrowIsSet = propPiImpl λ _ → propPiImpl (λ _ → isSetIsProp) + + propIsInverseOf : ∀ {A B f g} → isProp (IsInverseOf {A} {B} f g) + propIsInverseOf = propSig (arrowsAreSets _ _) (λ _ → arrowsAreSets _ _) + + 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 <<< identity ≡⟨ cong (λ φ → g <<< φ) (sym ε') ⟩ + g <<< (f <<< g') ≡⟨ isAssociative ⟩ + (g <<< f) <<< g' ≡⟨ cong (λ φ → φ <<< g') η ⟩ + identity <<< g' ≡⟨ leftIdentity ⟩ + g' ∎ + + 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 + 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 @@ -252,37 +568,38 @@ module _ {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where -- 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 +617,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,7 +630,7 @@ 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 -- @@ -324,38 +639,66 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where 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 ℂ._∘_ + 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 + open RawCategory opRaw - isIdentity : IsIdentity 𝟙 - isIdentity = swap ℂ.isIdentity + isPreCategory : IsPreCategory opRaw + IsPreCategory.isAssociative isPreCategory = sym ℂ.isAssociative + IsPreCategory.isIdentity isPreCategory = swap ℂ.isIdentity + IsPreCategory.arrowsAreSets isPreCategory = ℂ.arrowsAreSets - open Univalence isIdentity + open IsPreCategory isPreCategory 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) = {!!} + 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.isAssociative isCategory = sym ℂ.isAssociative - IsCategory.isIdentity isCategory = isIdentity - IsCategory.arrowsAreSets isCategory = ℂ.arrowsAreSets - IsCategory.univalent isCategory = univalent + IsCategory.isPreCategory isCategory = isPreCategory + IsCategory.univalent isCategory + = univalenceFromIsomorphism (isoToId* , inv) opposite : Category ℓa ℓb Category.raw opposite = opRaw @@ -373,8 +716,8 @@ module Opposite {ℓa ℓb : Level} where rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw RawCategory.Object (rawInv _) = Object RawCategory.Arrow (rawInv _) = Arrow - RawCategory.𝟙 (rawInv _) = 𝟙 - RawCategory._∘_ (rawInv _) = _∘_ + RawCategory.identity (rawInv _) = identity + RawCategory._<<<_ (rawInv _) = _<<<_ oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ oppositeIsInvolution = Category≡ rawInv diff --git a/src/Cat/Category/Exponential.agda b/src/Cat/Category/Exponential.agda index 76652d2..46aa1c0 100644 --- a/src/Cat/Category/Exponential.agda +++ b/src/Cat/Category/Exponential.agda @@ -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 ℂ diff --git a/src/Cat/Category/Functor.agda b/src/Cat/Category/Functor.agda index 390d8bc..b94dff2 100644 --- a/src/Cat/Category/Functor.agda +++ b/src/Cat/Category/Functor.agda @@ -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 diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index 3b65149..8d5abc6 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -17,25 +17,26 @@ 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 +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 ; 𝟙 ; _∘_ ; _>>>_) + open ℂ using (Object ; Arrow ; identity ; _<<<_ ; _>>>_) module M = Monoidal ℂ module K = Kleisli ℂ @@ -51,7 +52,7 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where private module MI = M.IsMonad m forthIsMonad : K.IsMonad (forthRaw raw) - K.IsMonad.isIdentity forthIsMonad = proj₂ MI.isInverse + K.IsMonad.isIdentity forthIsMonad = snd MI.isInverse K.IsMonad.isNatural forthIsMonad = MI.isNatural K.IsMonad.isDistributive forthIsMonad = MI.isDistributive @@ -68,26 +69,28 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where M.RawMonad.joinNT backRaw = joinNT private - open M.RawMonad backRaw + open M.RawMonad backRaw renaming + ( join to join* + ; pure to pure* + ; bind to bind* + ; fmap to fmap* + ) module R = Functor (M.RawMonad.R backRaw) 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.isAssociative backIsMonad = begin + join* <<< R.fmap join* ≡⟨⟩ + join <<< fmap join ≡⟨ isNaturalForeign ⟩ + join <<< join ∎ M.IsMonad.isInverse backIsMonad {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 ⟩ - 𝟙 ∎ + joinT X <<< R.fmap (pureT X) ≡⟨⟩ + join <<< fmap pure ≡⟨ snd isInverse ⟩ + identity ∎ back : K.Monad → M.Monad Monoidal.Monad.raw (back m) = backRaw m @@ -100,23 +103,23 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where → 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 ∎ + K.RawMonad.bind (forthRaw (backRaw m)) ≡⟨⟩ + (λ f → join <<< fmap f) ≡⟨⟩ + (λ f → bind (f >>> pure) >>> bind identity) ≡⟨ funExt lem ⟩ + (λ f → bind f) ≡⟨⟩ + bind ∎ 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 𝟙 + bind (f >>> pure) >>> bind identity ≡⟨ isDistributive _ _ ⟩ - bind ((f >>> pure) >>> bind 𝟙) + bind ((f >>> pure) >>> bind identity) ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (f >>> (pure >>> bind 𝟙)) + bind (f >>> (pure >>> bind identity)) ≡⟨ cong (λ φ → bind (f >>> φ)) (isNatural _) ⟩ - bind (f >>> 𝟙) + bind (f >>> identity) ≡⟨ cong bind ℂ.leftIdentity ⟩ bind f ∎ @@ -138,30 +141,30 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where bindEq : ∀ {X Y} {f : Arrow X (Romap Y)} → KM.bind f ≡ bind f bindEq {X} {Y} {f} = begin - KM.bind f ≡⟨⟩ - joinT Y ∘ Rfmap f ≡⟨⟩ - bind f ∎ + KM.bind f ≡⟨⟩ + joinT Y <<< fmap f ≡⟨⟩ + bind f ∎ joinEq : ∀ {X} → KM.join ≡ joinT X joinEq {X} = begin - KM.join ≡⟨⟩ - KM.bind 𝟙 ≡⟨⟩ - bind 𝟙 ≡⟨⟩ - joinT X ∘ Rfmap 𝟙 ≡⟨ cong (λ φ → _ ∘ φ) R.isIdentity ⟩ - joinT X ∘ 𝟙 ≡⟨ ℂ.rightIdentity ⟩ - joinT X ∎ + KM.join ≡⟨⟩ + KM.bind identity ≡⟨⟩ + bind identity ≡⟨⟩ + joinT X <<< fmap identity ≡⟨ cong (λ φ → _ <<< φ) R.isIdentity ⟩ + joinT X <<< identity ≡⟨ ℂ.rightIdentity ⟩ + joinT X ∎ - fmapEq : ∀ {A B} → KM.fmap {A} {B} ≡ Rfmap + fmapEq : ∀ {A B} → KM.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 >>> pureT B) >>> joinT B ≡⟨⟩ + fmap (f >>> pureT B) >>> joinT B ≡⟨ cong (λ φ → φ >>> joinT B) R.isDistributive ⟩ + fmap f >>> fmap (pureT B) >>> joinT B ≡⟨ ℂ.isAssociative ⟩ + joinT B <<< fmap (pureT B) <<< fmap f ≡⟨ cong (λ φ → φ <<< fmap f) (snd isInverse) ⟩ + identity <<< fmap f ≡⟨ ℂ.leftIdentity ⟩ + fmap f ∎ ) rawEq : Functor.raw KM.R ≡ Functor.raw R @@ -171,21 +174,19 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where Req : M.RawMonad.R (backRaw (forth m)) ≡ R Req = Functor≡ rawEq - open NaturalTransformation ℂ ℂ - pureTEq : M.RawMonad.pureT (backRaw (forth m)) ≡ pureT pureTEq = funExt (λ X → refl) - pureNTEq : (λ i → NaturalTransformation F.identity (Req i)) + pureNTEq : (λ i → NaturalTransformation Functors.identity (Req i)) [ M.RawMonad.pureNT (backRaw (forth m)) ≡ pureNT ] - pureNTEq = lemSigP (λ i → propIsNatural F.identity (Req i)) _ _ pureTEq + pureNTEq = lemSigP (λ i → propIsNatural Functors.identity (Req i)) _ _ pureTEq joinTEq : M.RawMonad.joinT (backRaw (forth 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 <<< fmap identity ≡⟨ cong (λ φ → joinT X <<< φ) R.isIdentity ⟩ + joinT X <<< identity ≡⟨ ℂ.rightIdentity ⟩ joinT X ∎) joinNTEq : (λ i → NaturalTransformation F[ Req i ∘ Req i ] (Req i)) @@ -205,8 +206,8 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where 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 : M.Monad ≅ K.Monad + Monoidal≊Kleisli = forth , back , funExt backeq , funExt fortheq - Monoidal≃Kleisli : M.Monad ≃ K.Monad - Monoidal≃Kleisli = forth , eqv + Monoidal≡Kleisli : M.Monad ≡ K.Monad + Monoidal≡Kleisli = isoToPath Monoidal≊Kleisli diff --git a/src/Cat/Category/Monad/Kleisli.agda b/src/Cat/Category/Monad/Kleisli.agda index 7377cdf..e0ebf86 100644 --- a/src/Cat/Category/Monad/Kleisli.agda +++ b/src/Cat/Category/Monad/Kleisli.agda @@ -1,22 +1,24 @@ {--- The Kleisli 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 -- "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 +34,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 +42,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 +50,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 +88,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 +112,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 +128,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 +139,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,21 +206,28 @@ 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 field diff --git a/src/Cat/Category/Monad/Monoidal.agda b/src/Cat/Category/Monad/Monoidal.agda index 360e5df..f5b20ad 100644 --- a/src/Cat/Category/Monad/Monoidal.agda +++ b/src/Cat/Category/Monad/Monoidal.agda @@ -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) + 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,48 +78,48 @@ 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 ∎ + 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) (fst isInverse) ⟩ + identity <<< f ≡⟨ ℂ.leftIdentity ⟩ + f ∎ isDistributive : IsDistributive isDistributive {X} {Y} {Z} g f = sym aux 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 ∎ + 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 <<< 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)) + 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) + (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 ≡⟨⟩ - ((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 + ((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) + joinT Z <<< R.fmap g <<< (joinT Y <<< R.fmap f) ∎ record Monad : Set ℓ where @@ -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) diff --git a/src/Cat/Category/Monad/Voevodsky.agda b/src/Cat/Category/Monad/Voevodsky.agda index f30aa9a..abc8438 100644 --- a/src/Cat/Category/Monad/Voevodsky.agda +++ b/src/Cat/Category/Monad/Voevodsky.agda @@ -1,25 +1,24 @@ {- This module provides construction 2.3 in [voe] -} -{-# OPTIONS --cubical --allow-unsolved-metas --caching #-} +{-# OPTIONS --cubical --caching #-} module Cat.Category.Monad.Voevodsky where open import Cat.Prelude -open import Function 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 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 ℂ @@ -50,9 +49,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,12 +71,12 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where } field - isMnd : IsMonad rawMnd + isMonad : IsMonad rawMnd toMonad : Monad toMonad = record { raw = rawMnd - ; isMonad = isMnd + ; isMonad = isMonad } record §2 : Set ℓ where @@ -94,43 +93,37 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where } field - isMnd : IsMonad rawMnd + isMonad : IsMonad rawMnd toMonad : Monad toMonad = record { raw = rawMnd - ; isMonad = isMnd + ; isMonad = isMonad } §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 + { fmap = Functor.fmap R ; RisFunctor = Functor.isFunctor R - ; pureN = pureN - ; join = λ {X} → joinT X - ; joinN = joinN - ; isMnd = M.Monad.isMonad m + ; pureN = pureN + ; join = λ {X} → joinT X + ; joinN = joinN + ; isMonad = 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 + open M.Monad m §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 + { bind = K.Monad.bind m + ; 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 +131,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 @@ -178,9 +171,6 @@ module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where 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) diff --git a/src/Cat/Category/Monoid.agda b/src/Cat/Category/Monoid.agda index 75eaa68..e813005 100644 --- a/src/Cat/Category/Monoid.agda +++ b/src/Cat/Category/Monoid.agda @@ -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 diff --git a/src/Cat/Category/NaturalTransformation.agda b/src/Cat/Category/NaturalTransformation.agda index 13e3d89..3771643 100644 --- a/src/Cat/Category/NaturalTransformation.agda +++ b/src/Cat/Category/NaturalTransformation.agda @@ -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 diff --git a/src/Cat/Category/Product.agda b/src/Cat/Category/Product.agda index 1ce45c5..4856668 100644 --- a/src/Cat/Category/Product.agda +++ b/src/Cat/Category/Product.agda @@ -1,13 +1,12 @@ -{-# 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 @@ -15,21 +14,19 @@ module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where 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,8 +47,8 @@ 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 ] @@ -68,8 +65,14 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object module y = IsProduct y module _ {X : Object} (f : ℂ [ X , A ]) (g : ℂ [ X , B ]) 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 _ _)) + + res = ∃-unique (x.ump f g) (y.ump f g) + prodAux : x.ump f g ≡ y.ump f g - prodAux = {!!} + 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 } @@ -83,6 +86,259 @@ module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object q : (λ i → IsProduct ℂ A B (p i)) [ Product.isProduct x ≡ Product.isProduct y ] q = lemPropF propIsProduct p +module Try0 {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} + (let module ℂ = Category ℂ) {𝒜 ℬ : ℂ.Object} where + + open P + + 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 + + private + 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 _≅_) + step0 + : ((X , xa , xb) ≡ (Y , ya , yb)) + ≅ (Σ[ p ∈ (X ≡ Y) ] (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb)) + 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 + : (Σ[ p ∈ (X ≡ Y) ] (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb)) + ≅ Σ (X ℂ.≊ Y) (λ iso + → let p = ℂ.isoToId iso + in + ( PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) + × PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb + ) + 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 + : Σ (X ℂ.≊ Y) (λ iso + → let p = ℂ.isoToId iso + in + ( PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) + × PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb + ) + ≅ ((X , xa , xb) ≊ (Y , ya , yb)) + 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 + + cat : Category _ _ + cat = record + { raw = raw + ; isCategory = isCat + } + + open Category cat + + lemma : Terminal ≃ Product ℂ 𝒜 ℬ + lemma = fromIsomorphism Terminal (Product ℂ 𝒜 ℬ) (f , g , inv) + -- C-x 8 RET MATHEMATICAL BOLD SCRIPT CAPITAL A + -- 𝒜 + 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 ℂ private @@ -90,31 +346,12 @@ 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 → Try0.propProduct _ _ propHasProducts : isProp (HasProducts ℂ) - propHasProducts = propHasProducts' + propHasProducts x y i = record { product = productEq x y i } + +fmap≡ : {A : Set} {a0 a1 : A} {B : Set} → (f : A → B) → Path a0 a1 → Path (f a0) (f a1) +fmap≡ = cong diff --git a/src/Cat/Category/Yoneda.agda b/src/Cat/Category/Yoneda.agda index 47ac1ec..c02274b 100644 --- a/src/Cat/Category/Yoneda.agda +++ b/src/Cat/Category/Yoneda.agda @@ -1,4 +1,4 @@ -{-# OPTIONS --allow-unsolved-metas --cubical #-} +{-# OPTIONS --cubical #-} module Cat.Category.Yoneda where @@ -6,8 +6,11 @@ open import Cat.Prelude open import Cat.Category open import Cat.Category.Functor +open import Cat.Category.NaturalTransformation + renaming (module Properties to F) + using () -open import Cat.Categories.Fun +open import Cat.Categories.Fun using (module Fun) open import Cat.Categories.Sets hiding (presheaf) -- There is no (small) category of categories. So we won't use _⇑_ from @@ -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} diff --git a/src/Cat/Equivalence.agda b/src/Cat/Equivalence.agda index b63e4ec..6e55cbf 100644 --- a/src/Cat/Equivalence.agda +++ b/src/Cat/Equivalence.agda @@ -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,7 +180,7 @@ 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 @@ -142,10 +190,7 @@ module _ {ℓa ℓb : Level} (A : Set ℓa) (B : Set ℓb) where 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 @@ -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 diff --git a/src/Cat/Prelude.agda b/src/Cat/Prelude.agda index f561330..6835262 100644 --- a/src/Cat/Prelude.agda +++ b/src/Cat/Prelude.agda @@ -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. @@ -46,20 +51,57 @@ module _ (ℓ : Level) where -- * 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) diff --git a/src/Cat/Wishlist.agda b/src/Cat/Wishlist.agda deleted file mode 100644 index 8385afd..0000000 --- a/src/Cat/Wishlist.agda +++ /dev/null @@ -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 = {!!}