Disable cube

Closes #26

.gitignore

@@ -1 +1 @@
-references/
+html/

.gitmodules

@@ -1,6 +1,6 @@
 [submodule "libs/cubical"]
 	path = libs/cubical
-	url = git@github.com:fredefox/cubical.git
+	url = git@github.com:Saizan/cubical-demo.git
 [submodule "libs/agda-stdlib"]
 	path = libs/agda-stdlib
 	url = git@github.com:agda/agda-stdlib.git

BACKLOG.md

@@ -0,0 +1,43 @@
+Backlog
+=======
+
+Prove univalence for the category of
+  * functors and natural transformations
+
+In AreInverses, dont use the "point-free" version. I.e.:
+
+  `∀ x → f x ≡ g x` rather than `f ≡ g`
+
+Ideas for future work
+---------------------
+
+It would be nice if my formulation of monads is not so "stand-alone" as it is at
+the moment.
+
+We can built up the notion of monads and related concept in multiple ways as
+demonstrated in the two equivalent formulations of monads (kleisli/monoidal):
+There seems to be a category-theoretic approach and an approach more in the
+style of functional programming as e.g. the related typeclasses in the
+standard library of Haskell.
+
+It would be nice to build up this hierarchy in two ways: The
+"category-theoretic" way and the "functional programming" way.
+
+Here is an overview of some of the concepts that need to be developed to acheive
+this:
+
+* Functor ✓
+* Applicative Functor ✗
+  * Lax monoidal functor ✗
+    * Monoidal functor ✗
+  * Tensorial strength ✗
+* Category ✓
+  * Monoidal category ✗
+* Monad
+  * Monoidal monad ✓
+  * Kleisli monad ✓
+  * Kleisli ≃ Monoidal ✓
+  * Problem 2.3 in [voe] ✓
+    * 1st contruction ~ monoidal ✓
+    * 2nd contruction ~ klesli ✓
+      * 1st ≃ 2nd ✓

CHANGELOG.md

@@ -0,0 +1,125 @@
+Change log
+=========
+
+Version 1.6.0
+-------------
+
+This version mainly contains changes to the report.
+
+This is the version I submit for my MSc..
+
+Version 1.5.0
+-------------
+Prove postulates in `Cat.Wishlist`:
+
+ * `ntypeCommulative : n ≤ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A`
+
+Prove that these two formulations of univalence are equivalent:
+
+    ∀ A B → isEquiv (A ≡ B) (A ≅ B) (id-to-iso A B)
+    ∀ A   → isContr (Σ[ X ∈ Object ] A ≅ X)
+
+Prove univalence for the category of...
+
+  * the opposite category
+  * sets
+  * "pair" category
+
+Finish the proof that products are propositional:
+
+  * `isProp (Product ...)`
+  * `isProp (HasProducts ...)`
+
+Remove --allow-unsolved-metas pragma from various files
+
+Also renamed a lot of different projections. E.g. arrow-composition, etc..
+
+Version 1.4.1
+-------------
+Defines a module to work with equivalence providing a way to go between
+equivalences and quasi-inverses (in the parlance of HoTT).
+
+Finishes the proof that the category of homotopy-sets are univalent.
+
+Defines a custom "prelude" module that wraps the `cubical` library and provides
+a few utilities.
+
+Reorders Category.isIdentity such that the left projection is left identity.
+
+Include some text for the half-time report.
+
+Renames IsProduct.isProduct to IsProduct.ump to avoid ambiguity in some
+circumstances.
+
+[WIP]: Adds some stuff about propositionality for products.
+
+Version 1.4.0
+-------------
+Adds documentation to a number of modules.
+
+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 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!
+
+[WIP] Started working on the proofs for univalence for the category of sets and
+the category of functors.
+
+Version 1.3.0
+-------------
+Removed unused modules and streamlined things more: All specific categories are
+in the name space `Cat.Categories`.
+
+Lemmas about categories are now in the appropriate record e.g. `IsCategory`.
+Also changed how category reexports stuff.
+
+Rename the module Properties to Yoneda - because that's all it talks about now.
+
+Rename Opposite to opposite
+
+Add documentation in Category-module
+
+Formulation of monads in two ways; the "monoidal-" and "Kleisli-" form.
+
+WIP: Equivalence of these two formulations
+
+Also use hSets in a few concrete categories rather than just pure `Set`.
+
+Version 1.2.0
+-------------
+This version is mainly a huge refactor.
+
+I've renamed
+
+* `distrib` to `isDistributive`
+* `arrowIsSet` to `arrowsAreSets`
+* `ident` to `isIdentity`
+* `assoc` to `isAssociative`
+
+And added "type-synonyms" for all of these. Their names should now match their
+type. So e.g. `isDistributive` has type `IsDistributive`.
+
+I've also changed how names are exported in `Functor` to be in line with
+`Category`.
+
+Version 1.1.0
+-------------
+In this version categories have been refactored - there's now a notion of a raw
+category, and a proper category which has the data (raw category) as well as
+the laws.
+
+Furthermore the type of arrows must be homotopy sets and they must satisfy univalence.
+
+I've made a module `Cat.Wishlist` where I just postulate things that I hope to
+implement upstream in `cubical`.
+
+I have proven that `IsCategory` is a mere proposition.
+
+I've also updated the category of sets to adhere to this new definition.

Makefile

@@ -0,0 +1,13 @@
+build: src/**.agda
+	agda --library-file ./libraries src/Cat.agda
+
+clean:
+	find src -name "*.agdai" -type f -delete
+
+html: src/**.agda
+	agda --html src/Cat.agda
+
+upload: html
+	scp -r html/ remote11.chalmers.se:www/cat/doc/
+
+.PHONY: upload clean

README.md

@@ -1,24 +1,52 @@
 Description
 ===========
-This project includes code as well as my masters thesis (currently just
-consisting of the proposal for the thesis).
+This project aims to formalize some parts of category theory using cubical agda
+— an extension to agda permitting univalence.  To learn more about this
+[read the docs](https://agda.readthedocs.io/en/latest/language/cubical.html).
 
-Installation
-============
-You probably need a very recent version of the Agda compiler. At the time
-of writing the solution has been tested with Agda version 2.6.0-9af3e07.
+This project draws a lot of inspiration from [the
+HoTT-book](https://homotopytypetheory.org/book/).
+
+If you want more information about this project, then you're in luck.
+This is my masters thesis.  Go ahead and read it
+[here](http://web.student.chalmers.se/~hanghj/papers/univalent-categories.pdf)
+or alternative like so:
+
+    cd doc/
+    make
 
 Dependencies
-------------
-I've used git submodules to manage dependencies. Unfortunately Agda does not
-allow specifying libraries to be used only as local dependencies.
+============
+To successfully compile the following is needed:
 
-You can let Agda know about these libraries by appending them to your global
-libraries file like so: (NB!: There is a good reason this is not in a
-makefile. So please verify that you know what you are doing, you probably
-already have standard-library in you libraries)
+* The master branch of Agda.
+* [Agda Standard Library](https://github.com/agda/agda-stdlib)
+* [Cubical](https://github.com/Saizan/cubical-demo/)
 
-    AGDA_LIB=~/.agda
-    readlink -f libs/*/*.agda-lib | tee -a $AGDA_LIB/libraries
+Has been tested with:
 
-Anyways, assuming you have this set up you should be good to go.
+  * Agda version 2.6.0-d3efe64
+
+Building
+========
+You can build the library with
+
+    git submodule update --init
+    make
+
+The Makefile takes care of using the right dependencies.
+Unfortunately I have not found a way to automatically inform
+`agda-mode` that it should use these dependencies.  So what you can do
+in stead is to copy these libraries to a global location and then add
+them system wide:
+
+    mkdir -p ~/.agda/libs
+    cd ~/.agda/libs
+    git clone $CAT/libs/std-lib
+    git clone $CAT/libs/cubical
+    echo << EOF | tee -a ~/.agda/libraries
+    $HOME/.agda/libs/agda-stdlib/standard-library.agda-lib
+    $HOME/.agda/libs/cubical/cubical.agda-lib
+    EOF
+
+Or you could symlink them as well if you want.

cat.agda-lib

@@ -7,3 +7,6 @@ depend:
   cubical
 include:
   src
+-- libraries:
+--   libs/agda-stdlib
+--   libs/cubical

doc/.gitignore

@@ -4,5 +4,12 @@
 *.log
 *.out
 *.pdf
+!assets/**
 *.bbl
 *.blg
+*.toc
+*.idx
+*.ilg
+*.ind
+*.nav
+*.snm

doc/BACKLOG.md

@@ -0,0 +1,95 @@
+Presentation
+====
+Find one clear goal.
+
+Remember crowd-control.
+
+Leave out:
+  lemPropF
+
+Outline
+-------
+
+Introduction
+
+A formalization of Category Theory in cubical Agda.
+
+Cubical Agda: A constructive interpretation of functional
+extensionality and univalence
+
+Talk about structure of library:
+===
+
+What can I say about reusability?
+
+Meeting with Andrea May 18th
+============================
+
+App. 2 in HoTT gives typing rule for pathJ including a computational
+rule for it.
+
+If you have this computational rule definitionally, then you wouldn't
+need to use `pathJprop`.
+
+In discussion-section I mention HITs. I should remove this or come up
+with a more elaborate example of something you could do, e.g.
+something with pushouts in the category of sets.
+
+The type Prop is a type where terms are *judgmentally* equal not just
+propositionally so.
+
+Maybe mention that Andreas Källberg is working on proving the
+initiality conjecture.
+
+Intensional Type Theory (ITT): Judgmental equality is decidable
+
+Extensional Type Theory (ETT): Reflection is enough to make judgmental
+equality undecidable.
+
+  Reflection : a ≡ b → a = b
+
+ITT does not have reflections.
+
+HTT ~ ITT + axiomatized univalence
+Agda ~ ITT + K-rule
+Coq  ~ ITT (no K-rule)
+Cubical Agda ~ ITT + Path + Glue
+
+Prop is impredicative in Coq (whatever that means)
+
+Prop ≠ hProp
+
+Comments about abstract
+-----
+
+Pattern matching for paths (?)
+
+Intro
+-----
+Main feature of judgmental equality is the conversion rule.
+
+Conor explained: K + eliminators ≡ pat. matching
+
+Explain jugmental equality independently of type-checking
+
+Soundness for equality means that if `x = y` then `x` and `y` must be
+equal according to the theory/model.
+
+Decidability of `=` is a necessary condition for typechecking to be
+decidable.
+
+Canonicity is a nice-to-have though without canonicity terms can get
+stuck. If we postulate results about judgmental equality. E.g. funext,
+then we can construct a term of type natural number that is not a
+numeral. Therefore stating canonicity with natural numbers:
+
+    ∀ t . ⊢ t : N , ∃ n : N . ⊢ t = sⁿ 0 : N
+
+is a sufficient condition to get a well-behaved equality.
+
+Eta-equality for RawFunctor means that the associative law for
+functors hold definitionally.
+
+Computational property for funExt is only relevant in two places in my
+whole formulation. Univalence and gradLemma does not influence any
+proofs.

doc/Makefile

@@ -0,0 +1,53 @@
+# Latex Makefile using latexmk
+# Modified by Dogukan Cagatay <dcagatay@gmail.com>
+# Originally from : http://tex.stackexchange.com/a/40759
+#
+# Change only the variable below to the name of the main tex file.
+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 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,
+# and '$<' is a variable holding the (first) dependency of a rule.
+# "raw2tex" and "dat2tex" are just placeholders for whatever custom steps
+# you might have.
+
+%.tex: %.raw
+	./raw2tex $< > $@
+
+%.tex: %.dat
+	./dat2tex $< > $@
+
+# MAIN LATEXMK RULE
+
+# -pdf tells latexmk to generate PDF directly (instead of DVI).
+# -pdflatex="" tells latexmk to call a specific backend with specific options.
+# -use-make tells latexmk to call make for generating missing files.
+
+# -interactive=nonstopmode keeps the pdflatex backend from stopping at a
+# missing file reference and interactively asking you for an alternative.
+
+$(PROJNAME).pdf: $(MAIN)
+	latexmk -jobname=$(PROJNAME) -pdf -xelatex -use-make $<
+
+cleanall:
+	latexmk -C
+
+clean:
+	latexmk -c
+
+read: all
+	xdg-open $(PROJNAME).pdf

doc/abstract.tex

@@ -0,0 +1,23 @@
+\chapter*{Abstract}
+The usual notion of propositional equality in intensional type-theory
+is restrictive.  For instance it does not admit functional
+extensionality nor univalence.  This poses a severe limitation on both
+what is \emph{provable} and the \emph{re-usability} of proofs.  Recent
+developments have, however, resulted in cubical type theory, which
+permits a constructive proof of univalence.  The programming language
+Agda has been extended with capabilities for working in such a cubical
+setting.  This thesis will explore the usefulness of this extension in
+the context of category theory.
+
+The thesis will motivate the need for univalence and explain why
+propositional equality in cubical Agda is more expressive than in
+standard Agda.  Alternative approaches to Cubical Agda will be
+presented and their pros and cons will be explained.  As an example of
+the application of univalence, two formulations of monads will be
+presented: Namely monads in the monoidal form and monads in the
+Kleisli form.  Using univalence, it will be shown how these are equal.
+
+Finally the thesis will explain the challenges that a developer will
+face when working with cubical Agda and give some techniques to
+overcome these difficulties.  It will suggest how further work can
+help alleviate some of these challenges.

doc/acknowledgements.tex

@@ -0,0 +1,13 @@
+\chapter*{Acknowledgements}
+I would like to thank my supervisor Thierry Coquand for giving me a
+chance to work on this interesting topic. I would also like to thank
+Andrea Vezzosi for some very long and very insightful meetings during
+the project. It is fascinating and almost uncanny how quickly Andrea
+can conjure up various proofs.  I also want to recognize the support
+of Knud Højgaards Fond who graciously sponsored me with a 20.000 DKK
+scholarship which helped toward sponsoring the two years I have spent
+studying abroad. I would also like to give a warm thanks to my fellow
+students Pierre~Kraft and Nachiappan~Valliappan who have made the time
+spent working on the thesis way more enjoyable. Lastly I would like to
+give a special thanks to Valentina~Méndez who have been a great moral
+support throughout the whole process.

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}

doc/appendix/abstract-funext.tex

@@ -0,0 +1,74 @@
+\chapter{Non-reducing functional extensionality}
+\label{app:abstract-funext}
+In two places in my formalization was the computational behaviours of
+functional extensionality used. The reduction behaviour can be
+disabled by marking functional extensionality as abstract. Below the
+fully normalized goal and context with functional extensionality
+marked abstract has been shown. The excerpts are from the module
+%
+\begin{center}
+\sourcelink{Cat.Category.Monad.Voevodsky}
+\end{center}
+%
+where this is also written as a comment next to the proofs. When
+functional extensionality is not abstract the goal and current value
+are the same. It is of course necessary to show the fully normalized
+goal and context otherwise the reduction behaviours is not forced.
+
+\subsubsection*{First goal}
+Goal:
+\begin{verbatim}
+PathP (λ _ → §2-3.§2 omap (λ {z} → pure))
+(§2-fromMonad
+ (.Cat.Category.Monad.toKleisli ℂ
+  (.Cat.Category.Monad.toMonoidal ℂ (§2-3.§2.toMonad m))))
+(§2-fromMonad (§2-3.§2.toMonad m))
+\end{verbatim}
+Have:
+\begin{verbatim}
+PathP
+(λ i →
+   §2-3.§2 K.IsMonad.omap
+   (K.RawMonad.pure
+    (K.Monad.raw
+     (funExt (λ m₁ → K.Monad≡ (.Cat.Category.Monad.toKleisliRawEq ℂ m₁))
+      i (§2-3.§2.toMonad m)))))
+(§2-fromMonad
+ (.Cat.Category.Monad.toKleisli ℂ
+  (.Cat.Category.Monad.toMonoidal ℂ (§2-3.§2.toMonad m))))
+(§2-fromMonad (§2-3.§2.toMonad m))
+\end{verbatim}
+\subsubsection*{Second goal}
+Goal:
+\begin{verbatim}
+PathP (λ _ → §2-3.§1 omap (λ {X} → pure))
+(§1-fromMonad
+ (.Cat.Category.Monad.toMonoidal ℂ
+  (.Cat.Category.Monad.toKleisli ℂ (§2-3.§1.toMonad m))))
+(§1-fromMonad (§2-3.§1.toMonad m))
+\end{verbatim}
+Have:
+\begin{verbatim}
+PathP
+(λ i →
+   §2-3.§1
+   (RawFunctor.omap
+    (Functor.raw
+     (M.RawMonad.R
+      (M.Monad.raw
+       (funExt
+        (λ m₁ → M.Monad≡ (.Cat.Category.Monad.toMonoidalRawEq ℂ m₁)) i
+        (§2-3.§1.toMonad m))))))
+   (λ {X} →
+      fst
+      (M.RawMonad.pureNT
+       (M.Monad.raw
+        (funExt
+         (λ m₁ → M.Monad≡ (.Cat.Category.Monad.toMonoidalRawEq ℂ m₁)) i
+         (§2-3.§1.toMonad m))))
+      X))
+(§1-fromMonad
+ (.Cat.Category.Monad.toMonoidal ℂ
+  (.Cat.Category.Monad.toKleisli ℂ (§2-3.§1.toMonad m))))
+(§1-fromMonad (§2-3.§1.toMonad m))
+\end{verbatim}

doc/chalmerstitle.sty

@@ -0,0 +1,140 @@
+% Requires: hypperref
+\ProvidesPackage{chalmerstitle}
+
+%% \RequirePackage{kvoptions}
+
+%% \SetupKeyvalOptions{
+%%   family=ct,
+%%   prefix=ct@
+%% }
+
+%% \DeclareStringOption{authoremail}
+%% \DeclareStringOption{supervisor}
+%% \DeclareStringOption{supervisoremail}
+%% \DeclareStringOption{supervisordepartment}
+%% \DeclareStringOption{cosupervisor}
+%% \DeclareStringOption{cosupervisoremail}
+%% \DeclareStringOption{cosupervisordepartment}
+%% \DeclareStringOption{examiner}
+%% \DeclareStringOption{examineremail}
+%% \DeclareStringOption{examinerdepartment}
+%% \DeclareStringOption{institution}
+%% \DeclareStringOption{department}
+%% \DeclareStringOption{researchgroup}
+%% \DeclareStringOption{subtitle}
+%% \ProcessKeyvalOptions*
+
+\newcommand*{\authoremail}[1]{\gdef\@authoremail{#1}}
+\newcommand*{\supervisor}[1]{\gdef\@supervisor{#1}}
+\newcommand*{\supervisoremail}[1]{\gdef\@supervisoremail{#1}}
+\newcommand*{\supervisordepartment}[1]{\gdef\@supervisordepartment{#1}}
+\newcommand*{\cosupervisor}[1]{\gdef\@cosupervisor{#1}}
+\newcommand*{\cosupervisoremail}[1]{\gdef\@cosupervisoremail{#1}}
+\newcommand*{\cosupervisordepartment}[1]{\gdef\@cosupervisordepartment{#1}}
+\newcommand*{\examiner}[1]{\gdef\@examiner{#1}}
+\newcommand*{\examineremail}[1]{\gdef\@examineremail{#1}}
+\newcommand*{\examinerdepartment}[1]{\gdef\@examinerdepartment{#1}}
+\newcommand*{\institution}[1]{\gdef\@institution{#1}}
+\newcommand*{\department}[1]{\gdef\@department{#1}}
+\newcommand*{\researchgroup}[1]{\gdef\@researchgroup{#1}}
+\newcommand*{\subtitle}[1]{\gdef\@subtitle{#1}}
+%% FRONTMATTER
+\newcommand*{\myfrontmatter}{%
+%% \newgeometry{top=3cm, bottom=3cm,left=2.25 cm, right=2.25cm}
+  \AddToShipoutPicture*{\backgroundpic{-4}{56.7}{assets/frontpage_gu_eng.pdf}}
+  \ClearShipoutPicture
+\addtolength{\voffset}{2cm}
+\begingroup
+\thispagestyle{empty}
+{\Huge\@title}\\[.5cm]
+{\Large A formalization of category theory in Cubical Agda}\\[6cm]
+\begin{center}
+\includegraphics[width=\linewidth,keepaspectratio]{assets/isomorphism.pdf}
+%% \includepdf{isomorphism.pdf}
+\end{center}
+% Cover text
+\vfill
+%% \renewcommand{\familydefault}{\sfdefault} \normalfont % Set cover page font
+{\Large\@author}\\[.5cm]
+Master's thesis in Computer Science
+\endgroup
+%% \end{titlepage}
+
+
+% BACK OF COVER PAGE (BLANK PAGE)
+\newpage
+%% \newgeometry{a4paper}	% Temporarily change margins
+\restoregeometry
+\thispagestyle{empty}
+\null
+}
+
+\renewcommand*{\maketitle}{%
+%% \begin{titlepage}
+
+% TITLE PAGE
+\newpage
+\thispagestyle{empty}
+\begin{center}
+	\textsc{\LARGE Master's thesis \the\year}\\[4cm]		% Report number is currently not in use
+	\textbf{\LARGE \@title} \\[1cm]
+	{\large \@subtitle}\\[1cm]
+	{\large \@author}
+	
+	\vfill	
+	\centering
+	\includegraphics[width=0.2\pdfpagewidth]{assets/logo_eng.pdf}
+  \vspace{5mm}
+	
+	\textsc{Department of Computer Science and Engineering}\\
+	\textsc{{\@researchgroup}}\\
+	%Name of research group (if applicable)\\
+	\textsc{\@institution} \\
+	\textsc{Gothenburg, Sweden \the\year}\\
+\end{center}
+
+
+% IMPRINT PAGE (BACK OF TITLE PAGE)
+\newpage
+\thispagestyle{plain}
+\textit{\@title}\\
+\@subtitle\\
+\copyright\ \the\year ~ \textsc{\@author}
+\vspace{4.5cm}
+
+\setlength{\parskip}{0.5cm}
+\textbf{Author:}\\
+\@author\\
+\href{mailto:\@authoremail>}{\texttt{<\@authoremail>}}
+
+\textbf{Supervisor:}\\
+\@supervisor\\
+\href{mailto:\@supervisoremail>}{\texttt{<\@supervisoremail>}}\\
+\@supervisordepartment
+
+\textbf{Co-supervisor:}\\
+\@cosupervisor\\
+\href{mailto:\@cosupervisoremail>}{\texttt{<\@cosupervisoremail>}}\\
+\@cosupervisordepartment
+
+\textbf{Examiner:}\\
+\@examiner\\
+\href{mailto:\@examineremail>}{\texttt{<\@examineremail>}}\\
+\@examinerdepartment
+
+\vfill
+Master's Thesis \the\year\\	% Report number currently not in use
+\@department\\
+%Division of Division name\\
+%Name of research group (if applicable)\\
+\@institution\\
+SE-412 96 Gothenburg\\
+Telephone +46 31 772 1000 \setlength{\parskip}{0.5cm}\\
+% Caption for cover page figure if used, possibly with reference to further information in the report
+%% Cover: Wind visualization constructed in Matlab showing a surface of constant wind speed along with streamlines of the flow. \setlength{\parskip}{0.5cm}
+%Printed by [Name of printing company]\\
+Gothenburg, Sweden \the\year
+
+%% \restoregeometry
+%% \end{titlepage}
+}

doc/conclusion.tex

@@ -0,0 +1,63 @@
+\chapter{Conclusion}
+This thesis highlighted some issues with the standard inductive
+definition of propositional equality used in Agda.  Functional
+extensionality and univalence are examples of two propositions not
+admissible in Intensional Type Theory (ITT).  This has a big impact on
+what is provable and the reusability of proofs.  This issue is
+overcome with an extension to Agda's type system called Cubical Agda.
+With Cubical Agda both functional extensionality and univalence are
+admissible.  Cubical Agda is more expressive, but there are certain
+issues that arise that are not present in standard Agda.  For one
+thing Agda enjoys Uniqueness of Identity Proofs (UIP) though a flag
+exists to turn this off.  This feature is not present in Cubical Agda.
+Rather than having unique identity proofs cubical Agda gives rise to a
+hierarchy of types with increasing \nomen{homotopical
+  structure}{homotopy levels}.  It turns out to be useful to build the
+formalization with this hierarchy in mind as it can simplify proofs
+considerably.  Another issue one must overcome in Cubical Agda is when
+a type has a field whose type depends on a previous field.  In this
+case paths between such types will be heterogeneous paths.  In
+practice it turns out to be considerably more difficult to work with
+heterogeneous paths than with homogeneous paths.  This thesis
+demonstrated the application of some techniques to overcome these
+difficulties, such as based path induction.
+
+This thesis formalizes some of the core concepts from category theory
+including: categories, functors, products, exponentials, Cartesian
+closed categories, natural transformations, the yoneda embedding,
+monads and more.  Category theory is an interesting case study for the
+application of cubical Agda for two reasons in particular. One reason
+is because category theory is the study of abstract algebra of
+functions, meaning that functional extensionality is particularly
+relevant.  Another reason is that in category theory it is commonplace
+to identify isomorphic structures.  Univalence allows for making this
+notion precise.  This thesis also demonstrated another technique that
+is common in category theory; namely to define categories to prove
+properties of other structures.  Specifically a category was defined
+to demonstrate that any two product objects in a category are
+isomorphic.  Furthermore the thesis showed two formulations of monads
+and proved that they indeed are equivalent: Namely monads in the
+monoidal- and Kleisli- form.  The monoidal formulation is more typical
+to category theoretic formulations and the Kleisli formulation will be
+more familiar to functional programmers.  It would have been very
+difficult to make a similar proof with setoids and the proof would be
+very difficult to read.  In the formulation we also saw how paths can
+be used to extract functions.  A path between two types induce an
+isomorphism between the two types.  This e.g.\ permits developers to
+write a monad instance for a given type using the Kleisli formulation.
+By transporting along the path between the monoidal- and Kleisli-
+formulation one can reuse all the operations and results shown for
+monoidal- monads in the context of kleisli monads.
+%%
+%% problem with inductive type
+%% overcome with cubical
+%% the path type
+%% homotopy levels
+%% depdendent paths
+%%
+%% category theory
+%% algebra of functions ~ funExt
+%% identify isomorphic types ~ univalence
+%% using categories to prove properties
+%% computational properties
+%% reusability, compositional

doc/cubical.tex

@@ -0,0 +1,428 @@
+\chapter{Cubical Agda}
+\section{Propositional equality}
+Judgmental equality in Agda is a feature of the type system. It is
+something that can be checked automatically by the type checker: In
+the example from the introduction $n + 0$ can be judged to be equal to
+$n$ simply by expanding the definition of $+$.
+
+On the other hand, propositional equality is something defined within
+the language itself. Propositional equality cannot be derived
+automatically. The normal definition of propositional equality is an
+inductive data type. Cubical Agda discards this type in favor of some
+new primitives.
+
+Most of the source code related with this section is implemented in
+\cite{cubical-demo} it can be browsed in hyperlinked and syntax
+highlighted HTML online. The links can be found in the beginning of
+section \S\ref{ch:implementation}.
+
+\subsection{The equality type}
+The usual notion of judgmental equality says that given a type $A \tp
+\MCU$ and two points hereof $a_0, a_1 \tp A$ we can form the type:
+%
+\begin{align}
+  a_0 \equiv a_1 \tp \MCU
+\end{align}
+%
+In Agda this is defined as an inductive data type with the single
+constructor $\refl$ that for any $a \tp A$ gives:
+%
+\begin{align}
+  \refl \tp a \equiv a
+\end{align}
+%
+There also exist a related notion of \emph{heterogeneous} equality which allows
+for equating points of different types. In this case given two types $A, B \tp
+\MCU$ and two points $a \tp A$, $b \tp B$ we can construct the type:
+%
+\begin{align}
+  a \cong b \tp \MCU
+\end{align}
+%
+This likewise has the single constructor $\refl$ that for any $a \tp
+A$ gives:
+%
+\begin{align}
+  \refl \tp a \cong a
+\end{align}
+%
+In Cubical Agda these two notions are paralleled with homogeneous- and
+heterogeneous paths respectively.
+%
+\subsection{The path type}
+Judgmental equality in Cubical Agda is encapsulated with the type:
+%
+\begin{equation}
+\Path \tp (P \tp \I → \MCU) → P\ 0 → P\ 1 → \MCU
+\end{equation}
+%
+The special type $\I$ is called the index set. The index set can be
+thought of simply as the interval on the real numbers from $0$ to $1$
+(both inclusive). The family $P$ over $\I$ will be referred to as the
+\nomenindex{path space} given some path $p \tp \Path\ P\ a\ b$. By
+that token $P\ 0$ corresponds to the type at the left endpoint of $p$.
+Likewise $P\ 1$ is the type at the right endpoint. The type is called
+$\Path$ because the idea has roots in homotopy theory. The intuition
+is that $\Path$ describes\linebreak[1] paths in $\MCU$. I.e.\ paths
+between types. For a path $p$ the expression $p\ i$ can be thought of
+as a \emph{point} on this path. The index $i$ describes how far along
+the path one has moved. An inhabitant of $\Path\ P\ a_0\ a_1$ is a
+(dependent) function from the index set to the path space:
+%
+$$
+p \tp \prod_{i \tp \I} P\ i
+$$
+%
+This function must satisfy being judgmentally equal to $a_0$ at the
+left endpoint and equal to $a_1$ at the other end. I.e.:
+%
+\begin{align*}
+  p\ 0 & = a_0 \\
+  p\ 1 & = a_1
+\end{align*}
+%
+The notion of \nomenindex{homogeneous equalities} is recovered when $P$ does not
+depend on its argument. That is for $A \tp \MCU$ and $a_0, a_1 \tp A$ the
+homogenous equality between $a_0$ and $a_1$ is the type:
+%
+$$
+a_0 \equiv a_1 \defeq \Path\ (\lambda\;i \to A)\ a_0\ a_1
+$$
+%
+I will generally prefer to use the notation $a \equiv b$ when talking
+about non-dependent paths and use the notation $\Path\ (\lambda\; i
+\to P\ i)\ a\ b$ when the path space is of particular interest.
+
+With this definition we can recover reflexivity. That is, for any $A
+\tp \MCU$ and $a \tp A$:
+%
+\begin{equation}
+\begin{aligned}
+\refl & \tp a \equiv a \\
+\refl & \defeq \lambda\; i \to a
+\end{aligned}
+\end{equation}
+%
+Here the path space is $P \defeq \lambda\; i \to A$ and it satsifies
+$P\ i = A$ definitionally. So to inhabit it, is to give a path $\I \to
+A$ that is judgmentally $a$ at either endpoint. This is satisfied by
+the constant path; i.e.\ the path that is constantly $a$ at any index
+$i \tp \I$.
+
+It is also surprisingly easy to show functional extensionality.
+Functional extensionality is the proposition that given a type $A \tp
+\MCU$, a family of types $B \tp A \to \MCU$ and functions $f, g \tp
+\prod_{a \tp A} B\ a$ gives:
+%
+\begin{equation}
+\label{eq:funExt}
+\funExt \tp \left(\prod_{a \tp A} f\ a \equiv g\ a \right) \to f \equiv g
+\end{equation}
+%
+%% p = λ\; i a → p a i
+So given $η \tp \prod_{a \tp A} f\ a \equiv g\ a$ we must give a path
+$f \equiv g$. That is a function $\I \to \prod_{a \tp A} B\ a$. So let
+$i \tp \I$ be given.  We must now give an expression $\phi \tp
+\prod_{a \tp A} B\ a$ satisfying $\phi\ 0 \equiv f\ a$ and $\phi\ 1
+\equiv g\ a$. This neccesitates that the expression must be a lambda
+abstraction, so let $a \tp A$ be given. We can now apply $a$ to $η$
+and get the path $η\ a \tp f\ a \equiv g\ a$. This exactly
+satisfies the conditions for $\phi$. In conclusion \ref{eq:funExt} is
+inhabited by the term:
+%
+\begin{equation*}
+\funExt\ η \defeq λ\; i\ a → η\ a\ i
+\end{equation*}
+%
+With $\funExt$ in place we can now construct a path between
+$\var{zeroLeft}$ and $\var{zeroRight}$ -- the functions defined in the
+introduction \S\ref{sec:functional-extensionality}:
+%
+\begin{align*}
+  p & \tp \var{zeroLeft} \equiv \var{zeroRight} \\
+  p & \defeq \funExt\ \var{zrn}
+\end{align*}
+%
+Here $\var{zrn}$ is the proof from \ref{eq:zrn}.
+%
+\section{Homotopy levels}
+In ITT all equality proofs are identical (in a closed context). This
+means that, in some sense, any two inhabitants of $a \equiv b$ are
+``equally good''. They do not have any interesting structure. This is
+referred to as Uniqueness of Identity Proofs (UIP). Unfortunately it
+is not possible to have a type theory with both univalence and UIP.
+Instead in cubical Agda we have a hierarchy of types with an
+increasing amount of homotopic structure. At the bottom of this
+hierarchy is the set of contractible types:
+%
+\begin{equation}
+\begin{aligned}
+%% \begin{split}
+& \isContr    && \tp    \MCU \to \MCU \\
+& \isContr\ A && \defeq \sum_{c \tp A} \prod_{a \tp A} a \equiv c
+%% \end{split}
+\end{aligned}
+\end{equation}
+%
+The first component of $\isContr\ A$ is called ``the center of contraction''.
+Under the propositions-as-types interpretation of type theory $\isContr\ A$ can
+be thought of as ``the true proposition $A$''. And indeed $\top$ is
+contractible:
+%
+\begin{equation*}
+(\var{tt} , \lambda\; x \to \refl) \tp \isContr\ \top
+\end{equation*}
+%
+It is a theorem that if a type is contractible, then it is isomorphic to the
+unit-type.
+
+The next step in the hierarchy is the set of mere propositions:
+%
+\begin{equation}
+\begin{aligned}
+& \isProp    && \tp \MCU \to \MCU \\
+& \isProp\ A && \defeq \prod_{a_0, a_1 \tp A} a_0 \equiv a_1
+\end{aligned}
+\end{equation}
+%
+One can think of $\isProp\ A$ as the set of true and false propositions. And
+indeed both $\top$ and $\bot$ are propositions:
+%
+\begin{align*}
+(λ\; \var{tt}, \var{tt} → refl) & \tp \isProp\ ⊤ \\
+λ\;\varnothing\ \varnothing   & \tp \isProp\ ⊥
+\end{align*}
+%
+The term $\varnothing$ is used here to denote an impossible pattern. It is a
+theorem that if a mere proposition $A$ is inhabited, then so is it contractible.
+If it is not inhabited it is equivalent to the empty-type (or false
+proposition).
+
+I will refer to a type $A \tp \MCU$ as a \emph{mere proposition} if I want to
+stress that we have $\isProp\ A$.
+
+The next step in the hierarchy is the set of homotopical sets:
+%
+\begin{equation}
+\begin{aligned}
+& \isSet    && \tp \MCU \to \MCU \\
+& \isSet\ A && \defeq \prod_{a_0, a_1 \tp A} \isProp\ (a_0 \equiv a_1)
+\end{aligned}
+\end{equation}
+%
+I will not give an example of a set at this point. It turns out that
+proving e.g.\ $\isProp\ \bN$ directly is not so straightforward (see
+\cite[\S3.1.4]{hott-2013}). Hedberg's theorem states that any type
+with decidable equality is a set. There will be examples of sets later
+in this report. At this point it should be noted that the term ``set''
+is somewhat conflated; there is the notion of sets from set theory.
+In Agda types are denoted \texttt{Set}. I will use it consistently to
+refer to a type $A$ as a set exactly if $\isSet\ A$ is a proposition.
+
+As the reader may have guessed the next step in the hierarchy is the type:
+%
+\begin{equation}
+\begin{aligned}
+& \isGroupoid    && \tp \MCU \to \MCU \\
+& \isGroupoid\ A && \defeq \prod_{a_0, a_1 \tp A} \isSet\ (a_0 \equiv a_1)
+\end{aligned}
+\end{equation}
+%
+So it continues.  In fact we can generalize this family of types by
+indexing them with a natural number. For historical reasons, though,
+the bottom of the hierarchy, the contractible types, is said to be a
+\nomen{-2-type}{homotopy levels}, propositions are
+\nomen{-1-types}{homotopy levels}, (homotopical) sets are
+\nomen{0-types}{homotopy levels} and so on\ldots
+
+Just as with paths, homotopical sets are not at the center of focus for this
+thesis. But I mention here some properties that will be relevant for this
+exposition:
+
+Proposition: Homotopy levels are cumulative. That is, if $A \tp \MCU$ has
+homotopy level $n$ then so does it have $n + 1$.
+
+For any level $n$ it is the case that to be of level $n$ is a mere proposition.
+%
+\section{A few lemmas}
+Rather than getting into the nitty-gritty details of Agda I venture to
+take a more ``combinator-based'' approach. That is I will use
+theorems about paths that have already been formalized.
+Specifically the results come from the Agda library \texttt{cubical}
+(\cite{cubical-demo}). I have used a handful of results from this
+library as well as contributed a few lemmas myself%
+\footnote{The module \texttt{Cat.Prelude} lists the upstream
+  dependencies.  My contribution to \texttt{cubical} can as well be
+  found in the git logs which are available at
+  \hrefsymb{https://github.com/Saizan/cubical-demo}{\texttt{https://github.com/Saizan/cubical-demo}}.
+}.
+
+These theorems are all purely related to homotopy type theory and as
+such not specific to the formalization of Category Theory. I will
+present a few of these theorems here as they will be used throughout
+chapter \ref{ch:implementation}. They should also give the reader some
+intuition about the path type.
+
+\subsection{Path induction}
+\label{sec:pathJ}
+The induction principle for paths intuitively gives us a way to reason
+about a type family indexed by a path by only considering if said path
+is $\refl$ (the \nomen{base case}{path induction}). For \emph{based
+  path induction}, that equality is \emph{based} at some element $a
+\tp A$.
+
+\pagebreak[3]
+\begin{samepage}
+Let a type $A \tp \MCU$ and an element of the type $a \tp A$ be
+given. $a$ is said to be the base of the induction.\linebreak[3] Given
+a family of types:
+%
+$$
+D \tp \prod_{b \tp A} \prod_{p \tp a ≡ b} \MCU
+$$
+%
+and an inhabitant of $D$ at $\refl$:
+%
+$$
+d \tp D\ a\ \refl
+$$
+We have the function:
+%
+\begin{equation}
+\pathJ\ D\ d \tp \prod_{b \tp A} \prod_{p \tp a ≡ b} D\ b\ p
+\end{equation}
+\end{samepage}%
+
+A simple application of $\pathJ$ is for proving that $\var{sym}$ is an
+involution. Namely for any set $A \tp \MCU$, points $a, b \tp A$ and a path
+between them $p \tp a \equiv b$:
+%
+\begin{equation}
+\label{eq:sym-invol}
+\var{sym}\ (\var{sym}\ p) ≡ p
+\end{equation}
+%
+The proof will be by induction on $p$ and will be based at $a$. That
+is $D$ will be the family:
+%
+\begin{align*}
+D         & \tp \prod_{b' \tp A} \prod_{p \tp a ≡ b'} \MCU \\
+D\ b'\ p' & \defeq \var{sym}\ (\var{sym}\ p') ≡ p'
+\end{align*}
+%
+The base case will then be:
+%
+\begin{align*}
+d & \tp \var{sym}\ (\var{sym}\ \refl) ≡ \refl \\
+d & \defeq \refl
+\end{align*}
+%
+The reason $\refl$ proves this is that $\var{sym}\ \refl = \refl$ holds
+definitionally. In summary \ref{eq:sym-invol} is inhabited by the term:
+%
+\begin{align*}
+  \pathJ\ D\ d\ b\ p
+  \tp
+  \var{sym}\ (\var{sym}\ p) ≡ p
+\end{align*}
+%
+Another application of $\pathJ$ is for proving associativity of $\trans$. That
+is, given a type $A \tp \MCU$, elements of $A$, $a, b, c, d \tp A$ and paths
+between them $p \tp a \equiv b$, $q \tp b \equiv c$ and $r \tp c \equiv d$ we
+have the following:
+%
+\begin{equation}
+  \label{eq:cum-trans}
+  \trans\ p\ (\trans\ q\ r) ≡ \trans\ (\trans\ p\ q)\ r
+\end{equation}
+%
+In this case the induction will be based at $c$ (the left-endpoint of $r$) and
+over the family:
+%
+\begin{align*}
+  T       & \tp \prod_{d' \tp A} \prod_{r' \tp c ≡ d'} \MCU \\
+  T\ d'\ r' & \defeq \trans\ p\ (\trans\ q\ r') ≡ \trans\ (\trans\ p\ q)\ r'
+\end{align*}
+%
+The base case is proven with $t$ which is defined as:
+%
+\begin{align*}
+  \trans\ p\ (\trans\ q\ \refl) & ≡
+  \trans\ p\ q \\
+   & ≡
+  \trans\ (\trans\ p\ q)\ \refl
+\end{align*}
+%
+Here we have used the proposition $\trans\ p\ \refl \equiv p$ without proof. In
+conclusion \ref{eq:cum-trans} is inhabited by the term:
+%
+\begin{align*}
+\pathJ\ T\ t\ d\ r
+\end{align*}
+%
+We shall see another application of path induction in \ref{eq:pathJ-example}.
+
+\subsection{Paths over propositions}
+\label{sec:lemPropF}
+Another very useful combinator is $\lemPropF$: Given a type $A \tp
+\MCU$ and a type family on $A$; $D \tp A \to \MCU$. Let $\var{propD}
+\tp \prod_{x \tp A} \isProp\ (D\ x)$ be the proof that $D$ is a mere
+proposition for all elements of $A$. Furthermore say we have a path
+between some two elements in $A$; $p \tp a_0 \equiv a_1$ then we can
+built a heterogeneous path between any two elements of $d_0 \tp
+D\ a_0$ and $d_1 \tp D\ a_1$.
+%
+$$
+\lemPropF\ \var{propD}\ p \tp \Path\ (\lambda\; i \mto D\ (p\ i))\ d_0\ d_1
+$$
+%
+Note that $d_0$ and $d_1$, though points of the same family, have
+different types. This is quite a mouthful, so let me try to show how
+this is a very general and useful result.
+
+Often when proving equalities between elements of some dependent types
+$\lemPropF$ can be used to boil this complexity down to showing that
+the dependent parts of the type are mere propositions. For instance
+say we have a type:
+%
+$$
+T \defeq \sum_{a \tp A} D\ a
+$$
+%
+for some proposition $D \tp A \to \MCU$. That is we have $\var{propD}
+\tp \prod_{a \tp A} \isProp\ (D\ a)$. If we want to prove $t_0 \equiv
+t_1$ for two elements $t_0, t_1 \tp T$ then this will be a pair of
+paths:
+%
+%
+\begin{align*}
+  p \tp & \fst\ t_0 \equiv \fst\ t_1 \\
+        & \Path\ (\lambda\; i \to D\ (p\ i))\ (\snd\ t_0)\ (\snd\ t_1)
+\end{align*}
+%
+Here $\lemPropF$ directly allow us to prove the latter of these given
+that we have already provided $p$.
+%
+$$
+\lemPropF\ \var{propD}\ p
+  \tp \Path\ (\lambda\; i \to D\ (p\ i))\ (\snd\ t_0)\ (\snd\ t_1)
+$$
+%
+\subsection{Functions over propositions}
+\label{sec:propPi}%
+$\prod$-types preserve propositionality when the co-domain is always a
+proposition.
+%
+$$
+\mathit{propPi} \tp \left(\prod_{a \tp A} \isProp\ (P\ a)\right) \to \isProp\ \left(\prod_{a \tp A} P\ a\right)
+$$
+\subsection{Pairs over propositions}
+\label{sec:propSig}
+%
+$\sum$-types preserve propositionality whenever its first component is
+a proposition and its second component is a proposition for all
+points of the left type.
+%
+$$
+\mathit{propSig} \tp \isProp\ A \to \left(\prod_{a \tp A} \isProp\ (P\ a)\right) \to \isProp\ \left(\sum_{a \tp A} P\ a\right)
+$$

doc/discussion.tex

@@ -0,0 +1,139 @@
+\chapter{Perspectives}
+\section{Discussion}
+In the previous chapter the practical aspects of proving things in
+Cubical Agda were highlighted.  I also demonstrated the usefulness of
+separating ``laws'' from ``data''.  One of the reasons for this is that
+dependencies within types can lead to very complicated goals.  One
+technique for alleviating this was to prove that certain types are
+mere propositions.
+
+\subsection{Computational properties}
+The new contribution of cubical Agda is that it has a constructive
+proof of functional extensionality\index{functional extensionality}
+and univalence\index{univalence}.  This means in particular that the
+type checker can reduce terms defined with these theorems.  One
+interesting result of this development is how much this influenced the
+development.  In particular having a functional extensionality that
+``computes'' should simplify some proofs.
+
+I have tested this by using a feature of Agda where one can mark
+certain bindings as being \emph{abstract}.  This means that the
+type-checker will not try to reduce that term further during type
+checking.  I tried making univalence and functional extensionality
+abstract.  It turns out that the conversion behaviour of univalence is
+not used anywhere.  For functional extensionality there are two places
+in the whole solution where the reduction behaviour is used to
+simplify some proofs.  This is in showing that the maps between the
+two formulations of monads are inverses.  See the notes in this
+module:
+%
+\begin{center}
+\sourcelink{Cat.Category.Monad.Voevodsky}
+\end{center}
+%
+
+I will not reproduce it in full here as the type is quite involved. In
+stead I have put this in a source listing in
+\ref{app:abstract-funext}.  The method used to find in what places the
+computational behaviour of these proofs are needed has the caveat of
+only working for places that directly or transitively uses these two
+proofs.  Fortunately though the code is structured in such a way that
+this is the case. In conclusion the way I have structured these proofs
+means that the computational behaviour of functional extensionality
+and univalence has not been so relevant.
+
+Barring this the computational behaviour of paths can still be useful.
+E.g.\ if a programmer wants to reuse functions that operate on a
+monoidal monads to work with a monad in the Kleisli form that the
+programmer has specified.  To make this idea concrete, say we are
+given some function $f \tp \Kleisli \to T$, having a path between $p
+\tp \Monoidal \equiv \Kleisli$ induces a map $\coe\ p \tp \Monoidal
+\to \Kleisli$.  We can compose $f$ with this map to get $f \comp
+\coe\ p \tp \Monoidal \to T$.  Of course, since that map was
+constructed with an isomorphism, these maps already exist and could be
+used directly.  So this is arguably only interesting when one also
+wants to prove properties of applying such functions.
+
+\subsection{Reusability of proofs}
+The previous example illustrate how univalence unifies two otherwise
+disparate areas: The category-theoretic study of monads; and monads as
+in functional programming.  Univalence thus allows one to reuse proofs.
+You could say that univalence gives the developer two proofs for the
+price of one.  As an illustration of this I proved that monads are
+groupoids.  I initially proved this for the Kleisli
+formulation\footnote{Actually doing this directly turned out to be
+  tricky as well, so I defined an equivalent formulation which was not
+  formulated with a record, but purely with $\sum$-types.}.  Since the
+two formulations are equal under univalence, substitution directly
+gives us that this also holds for the monoidal formulation.  This of
+course generalizes to any family $P \tp 𝒰 → 𝒰$ where $P$ is inhabited
+at either formulation (i.e.\ either $P\ \Monoidal$ or $P\ \Kleisli$
+holds).
+
+The introduction (section \S\ref{sec:context}) mentioned that a
+typical way of getting access to functional extensionality is to work
+with setoids.  Nowhere in this formalization has this been necessary,
+$\Path$ has been used globally in the project for propositional
+equality.  One interesting place where this becomes apparent is in
+interfacing with the Agda standard library.  Multiple definitions in
+the Agda standard library have been designed with the
+setoid-interpretation in mind.  E.g.\ the notion of \emph{unique
+  existential} is indexed by a relation that should play the role of
+propositional equality.  Equivalence relations are likewise indexed,
+not only by the actual equivalence relation but also by another
+relation that serve as propositional equality.
+%% Unfortunately we cannot use the definition of equivalences found in
+%% the standard library to do equational reasoning directly.  The
+%% reason for this is that the equivalence relation defined there must
+%% be a homogenous relation, but paths are heterogeneous relations.
+
+In the formalization at present a significant amount of energy has
+been put towards proving things that would not have been needed in
+classical Agda.  The proofs that some given type is a proposition were
+provided as a strategy to simplify some otherwise very complicated
+proofs (e.g.\ \ref{eq:proof-prop-IsPreCategory}
+and \ref{eq:productPath}).  Often these proofs would not be this
+complicated.  If the J-rule holds definitionally the proof-assistant
+can help simplify these goals considerably.  The lack of the J-rule has
+a significant impact on the complexity of these kinds of proofs.
+
+\subsection{Motifs}
+An oft-used technique in this development is using based path
+induction to prove certain properties.  One particular challenge that
+arises when doing so is that Agda is not able to automatically infer
+the family that one wants to do induction over.  For instance in the
+proof $\var{sym}\ (\var{sym}\ p) ≡ p$ from \ref{eq:sym-invol} the
+family that we chose to do induction over was $D\ b'\ p' \defeq
+\var{sym}\ (\var{sym}\ p') ≡ p'$.  However, if one interactively tries
+to give this hole, all the information that Agda can provide is that
+one must provide an element of $𝒰$.  Agda could be more helpful in this
+context, perhaps even infer this family in some situations.  In this
+very simple example this is of course not a big problem, but there are
+examples in the source code where this gets more involved.
+
+\section{Future work}
+\subsection{Compiling Cubical Agda}
+\label{sec:compiling-cubical-agda}
+Compilation of program written in Cubical Agda is currently not
+supported.  One issue here is that the backends does not provide an
+implementation for the cubical primitives (such as the path-type).
+This means that even though the path-type gives us a computational
+interpretation of functional extensionality, univalence, transport,
+etc., we do not have a way of actually using this to compile our
+programs that use these primitives.  It would be interesting to see
+practical applications of this.
+
+\subsection{Proving laws of programs}
+Another interesting thing would be to use the Kleisli formulation of
+monads to prove properties of functional programs.  The existence of
+univalence will make it possible to re-use proofs stated in terms of
+the monoidal formulation in this setting.
+
+%% \subsection{Higher inductive types}
+%% This library has not explored the usefulness of higher inductive types
+%% in the context of Category Theory.
+
+\subsection{Initiality conjecture}
+A fellow student at Chalmers, Andreas Källberg, is currently working
+on proving the initiality conjecture.  He will be using this library
+to do so.

doc/feedback-meeting-andrea.txt

@@ -0,0 +1,9 @@
+App. 2 in HoTT gives typing rule for pathJ including a computational
+rule for it.
+
+If you have this computational rule definitionally, then you wouldn't
+need to use `pathJprop`.
+
+In discussion-section I mention HITs. I should remove this or come up
+with a more elaborate example of something you could do, e.g.
+something with pushouts in the category of sets.

doc/feedback.txt

@@ -0,0 +1,72 @@
+Andrea Vezzosi <vezzosi@chalmers.se>	Tue, Apr 24, 2018 at 2:02 PM
+To: Frederik Hanghøj Iversen <fhi.1990@gmail.com>
+Cc: Thierry Coquand <coquand@chalmers.se>
+On Tue, Apr 24, 2018 at 12:57 PM, Frederik Hanghøj Iversen
+<fhi.1990@gmail.com> wrote:
+> I've written the first few sections about my implementation. I was wondering
+> if you could have a quick look at it. You don't need to read it
+> word-for-word but I would like some indication from you if this is the sort
+> of thing you would like to see in the final report.
+
+Yes! I would say this very much fits the bill of what the main part of
+the report should be, then you could have a discussion section where
+you might put some analysis of the pros and cons of cubical, design
+choices you made, and your experience overall.
+
+I wonder if there should be some short introduction to Cubical Type
+Theory before this chapter, so you can introduce the Path type by
+itself and show some simple proof with it. e.g. how to get function
+extensionality.
+
+You mention a few "combinators" like propPi and lemPropF, you might
+want to call them just lemmas, so it's clearer that these can be
+proven in --cubical.
+
+>
+> I refer you specifically to "Chapter 2 - Implementation" on p. 6.
+>
+> In this chapter I plan to additionally include some text about the proof we
+> did that products are mere propositions and the proof about the two
+> equivalent notions of a monad.
+
+I've read the chapter up until 2.3 and skimmed the rest for now, but I
+accumulated some editing suggestions I copy here.
+Remember to look for things like these when you proof-read the rest :)
+
+
+You should be careful to properly introduce things before you use
+them, like IsPreCategory (I'd prefer if it took the raw category as
+argument btw) and its fields isIdentity, isAssociative, .. come up a
+bit out of the blue from the end of page 8.
+Maybe the easiest is to show the definition of IsPreCategory.
+
+Maybe give a type for propIsIdentity and mention the other prop* are similar.
+
+Also the notation "isIdentity_a" to apply projections is a bit unusual
+so it needs to be introduced as well.
+To be fair it would be simpler to stick to function application
+(though I see that it would introduce more parentheses),
+
+"The situation is a bit more complicated when we have a dependent
+type" could be more clear by being more specific:
+"The situation is a bit more complicated when the type of a field
+depends on a previous field"
+
+Here too it might be more concrete if you also give the code for IsCategory.
+
+In Path ( λ i → Univalent_{p i} ) isPreCategory_a isPreCategory_b
+I suggest parentheses around (p i), but also you should be consistent
+on whether you want to call the proof "p" or "p_{isPreCategory}",
+finally i'm guessing the two fields should be "isUnivalent" rather
+than "isPreCategory".
+
+You can cite the book on the specific definition of isEquiv,
+"contractible fibers" in section 4.4, the grad lemma is also from
+somewhere but I don't remember off-hand.
+
+You have not defined what you mean by _\~=_ and isomorphism.
+
+
+Cheers,
+Andrea
+[Quoted text hidden]

doc/halftime.tex

@@ -0,0 +1,259 @@
+\chapter{Halftime report}
+I've written this as an appendix because 1) the aim of the thesis changed
+drastically from the planning report/proposal 2) partly I'm not sure how to
+structure my thesis.
+
+My work so far has very much focused on the formalization, i.e.\ coding. It's
+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.
+
+\section{Implementation overview}
+The overall structure of my project is as follows:
+
+\begin{itemize}
+\item Core categorical concepts
+\subitem Categories
+\subitem Functors
+\subitem Products
+\subitem Exponentials
+\subitem Cartesian closed categories
+\subitem Natural transformations
+\subitem Yoneda embedding
+\subitem Monads
+\subsubitem Monoidal monads
+\subsubitem Kleisli monads
+\subsubitem Voevodsky's construction
+\item Category of \ldots
+\subitem Homotopy sets
+\subitem Categories
+\subitem Relations
+\subitem Functors
+\subitem Free category
+\end{itemize}
+
+I also started work on the category with families as well as the cubical
+category as per the original goal of the thesis. However I have not gotten so
+far with this.
+
+In the following I will give an overview of overall results in each of these
+categories (no pun).
+
+As an overall design-guideline I've defined concepts in a such a way that the
+``data'' and the ``laws'' about that data is split up in seperate modules. 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 mathematical way, where one can
+reason about two categories by simply focusing on the data. This is acheived by
+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.
+
+\subsection{Categories}
+Defines the basic notion of a category. This definition closely follows that of
+[HoTT]: That is, the standard definition of a category (data; objects, arrows,
+composition and identity, laws; preservation of identity and composition) plus
+the extra condition that it is univalent - namely that you can get an equality
+of two objects from an isomorphism.
+
+I make no distinction between a pre category and a real category (as in the
+[HoTT]-sense). A pre category in my implementation would be a category sans the
+witness to univalence.
+
+I also prove that being a category is a proposition. This gives rise to an
+equality principle for monads that focuses on the data-part.
+
+I also show that the opposite category is indeed a category. (\WIP{} I have not
+shown that univalence holds for such a construction)
+
+I also show that taking the opposite is an involution.
+
+\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.
+
+\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.
+
+\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.
+
+\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.
+
+\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.
+
+Proof that naturality is a mere proposition and the accompanying equality
+principle. Proof that natural transformations are homotopic sets.
+
+The identity natural transformation.
+
+\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.
+
+\subsection{Monads}
+
+Defines an equivalence between these two formulations of a monad:
+
+\subsubsection{Monoidal monads}
+
+Defines the standard monoidal representation of a monad:
+
+An endofunctor with two natural transformations (called ``pure'' and ``join'')
+and some laws about these natural transformations.
+
+Propositionality proofs and equality principle is provided.
+
+\subsubsection{Kleisli monads}
+
+A presentation of monads perhaps more familiar to a functional programer:
+
+A map on objects and two maps on morphisms (called ``pure'' and ``bind'') and
+some laws about these maps.
+
+Propositionality proofs and equality principle is provided.
+
+\subsubsection{Voevodsky's construction}
+
+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.}
+
+\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:
+%
+$$\hSet_\ell \defeq \sum_{A \tp \MCU_\ell} \isSet\ A$$
+%
+The definition of univalence for categories I have defined is:
+%
+$$\isEquiv\ (\hA \equiv \hB)\ (\hA \cong \hB)\ \idToIso$$
+%
+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.
+
+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.
+
+\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.
+
+\subsection{Relations}
+The category of relations. \WIP{} I have not shown that this category is
+univalent. Not sure I intend to do so either.
+
+\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*}
+%

doc/introduction.tex

@@ -0,0 +1,266 @@
+\chapter{Introduction}
+This thesis is a case study in the application of cubical Agda to the
+formalization of category theory. At the center of this is the notion
+of \nomenindex{equality}. There are two pervasive notions of equality
+in type theory: \nomenindex{judgmental equality} and
+\nomenindex{propositional equality}. Judgmental equality is a property
+of the type system.  Propositional equality on the other hand is
+usually defined \emph{within} the system.  When introducing
+definitions this report will use the symbol $\defeq$.  Judgmental
+equalities will be denoted with $=$ and for propositional equalities
+the notation $\equiv$ is used.
+
+The rules of judgmental equality are related with $β$- and
+$η$-reduction, which gives a notion of computation in a given type
+theory.
+%
+There are some properties that one usually want judgmental equality to
+satisfy. It must be \nomenindex{sound}, enjoy \nomenindex{canonicity}
+and be a \nomenindex{congruence relation}. Soundness means that things
+judged to be equal are equal with respects to the \nomenindex{model}
+of the theory or the \emph{meta theory}. It must be a congruence
+relation, because otherwise the relation certainly does not adhere to
+our notion of equality. E.g.\ One would be able to conclude things
+like: $x \equiv y \rightarrow f\ x \nequiv f\ y$. Canonicity means
+that any well typed term evaluates to a \emph{canonical} form. For
+example, for a closed term $e \tp \bN$, it will be the case that $e$
+reduces to $n$ applications of $\mathit{suc}$ to $0$ for some $n$;
+i.e.\ $e = \mathit{suc}^n\ 0$.  Without canonicity terms in the
+language can get ``stuck'', meaning that they do not reduce to a
+canonical form.
+
+For a system to work as a programming languages it is necessary for
+judgmental equality to be \nomenindex{decidable}. Being decidable
+simply means that that an algorithm exists to decide whether two terms
+are equal.  For any practical implementation, the decidability must
+also be effectively computable.
+
+For propositional equality the decidability requirement is relaxed. It
+is not in general possible to decide the correctness of logical
+propositions (cf.\ Hilbert's \emph{entscheidigungsproblem}).
+
+There are two flavors of type-theory. \emph{Intensional-} and
+\emph{extensional-} type theory (ITT and ETT respectively). Identity
+types in extensional type theory are required to be
+\nomen{propositions}{proposition}. That is, a type with at most one
+inhabitant. In extensional type theory the principle of reflection
+%
+$$a ≡ b → a = b$$
+%
+is enough to make type checking undecidable. This report focuses on
+Agda, which at a glance can be thought of as a version of intensional
+type theory. Pattern-matching in regular Agda lets one prove
+\nomenindex{Uniqueness of Identity Proofs} (UIP). UIP states that any
+two identity proofs are propositionally identical.
+
+The usual notion of propositional equality in ITT is quite
+restrictive.  In the next section a few motivating examples will be
+presented that highlight.  There exist techniques to circumvent these
+problems, as we shall see.  This thesis will explore an extension to
+Agda that redefines the notion of propositional equality and as such
+is an alternative to these other techniques.  The extension is called
+cubical Agda.  Cubical Agda drops UIP, as it does not permit
+\nomenindex{functional extensionality} nor \nomenindex{univalence}.
+What makes cubical Agda particularly interesting is that it gives a
+\emph{constructive} interpretation of univalence.  What all this means
+will be elaborated in the following sections.
+%
+\section{Motivating examples}
+%
+In the following two sections I present two examples that illustrate
+some limitations inherent in ITT and, by extension, Agda.
+%
+\subsection{Functional extensionality}
+\label{sec:functional-extensionality}%
+Consider the functions:
+%
+\begin{align*}%
+\var{zeroLeft}  & \defeq λ\; (n \tp \bN) \to (0 + n \tp \bN) \\
+\var{zeroRight} & \defeq λ\; (n \tp \bN) \to (n + 0 \tp \bN)
+\end{align*}%
+%
+The term $n + 0$ is \nomenindex{definitionally} equal to $n$, which we
+write as $n + 0 = n$.  This is also called \nomenindex{judgmental
+  equality}.   We call it definitional equality because the
+\emph{equality} arises from the \emph{definition} of $+$, which is:
+%
+\begin{align*}
+  +             & \tp \bN \to \bN \to \bN      \\
+  n + 0         & \defeq n                     \\
+  n + (\suc{m}) & \defeq \suc{(n + m)}
+\end{align*}
+%
+Note that $0 + n$ is \emph{not} definitionally equal to $n$.  This is
+because $0 + n$ is in normal form.  I.e.\ there is no rule for $+$
+whose left hand side matches this expression.  We do, however, have that
+they are \nomen{propositionally}{propositional equality} equal, which
+we write as $n \equiv n + 0$.  Propositional equality means that there
+is a proof that exhibits this relation.  We can do induction over $n$
+to prove this:
+%
+\begin{align}
+\label{eq:zrn}
+\begin{split}
+\var{zrn}\                & \tp    ∀ n → n ≡ \var{zeroRight}\ n \\
+\var{zrn}\ \var{zero}     & \defeq \var{refl} \\
+\var{zrn}\ (\var{suc}\ n) & \defeq \var{cong}\ \var{suc}\ (\var{zrn}\ n)
+\end{split}
+\end{align}
+%
+This show that zero is a right neutral element (hence the name
+$\var{zrn}$).  Since equality is a transitive relation we have that
+$\forall n \to \var{zeroLeft}\ n \equiv \var{zeroRight}\ n$.
+Unfortunately we don't have $\var{zeroLeft} \equiv \var{zeroRight}$.
+There is no way to construct a proof asserting the obvious equivalence
+of $\var{zeroLeft}$ and $\var{zeroRight}$.  Actually showing this is
+outside the scope of this text.  It would essentially involve giving a
+model for our type theory that validates all our axioms but where
+$\var{zeroLeft} \equiv \var{zeroRight}$ is not true.  We cannot show
+that they are equal even though we can prove them equal for all
+points.  This is exactly the notion of equality that we are interested
+in for functions: Functions are considered equal when they are equal
+for all inputs.  This is called \nomenindex{pointwise equality} where
+\emph{points} of a function refer to its arguments.
+%
+\subsection{Equality of isomorphic types}
+%
+Let $\top$ denote the unit type -- a type with a single constructor.
+In the propositions as types interpretation of type theory $\top$ is
+the proposition that is always true.  The type $A \x \top$ and $A$ has
+an element for each $a \tp A$.  So in a sense they have the same shape
+(Greek; \nomenindex{isomorphic}).  The second element of the pair does
+not add any ``interesting information''.  It can be useful to identify
+such types.  In fact it is quite commonplace in mathematics.  Say we
+look at a set $\{x \mid \phi\ x \land \psi\ x\}$ and somehow conclude
+that $\psi\ x \equiv \top$ for all $x$.  A mathematician would
+immediately conclude $\{x \mid \phi\ x \land \psi\ x\} \equiv \{x \mid
+\phi\ x\}$ without thinking twice.  Unfortunately such an
+identification can not be performed in ITT.
+
+More specifically what we are interested in is a way of identifying
+\nomenindex{equivalent} types.  I will return to the definition of
+equivalence later in section \S\ref{sec:equiv}, but for now it is
+sufficient to think of an equivalence as a one-to-one correspondence.
+We write $A \simeq B$ to assert that $A$ and $B$ are equivalent types.
+The principle of univalence says that:
+%
+$$\mathit{univalence} \tp (A \simeq B) \simeq (A \equiv B)$$
+%
+In particular this allows us to construct an equality from an equivalence
+%
+$$\mathit{ua} \tp (A \simeq B) \to (A \equiv B)$$
+%
+and vice versa.
+
+\section{Formalizing Category Theory}
+%
+The above examples serve to illustrate a limitation of ITT.  One case
+where these limitations are particularly prohibitive is in the study
+of Category Theory.  At a glance category theory can be described as
+``the mathematical study of (abstract) algebras of functions''
+(\cite{awodey-2006}).  By that token functional extensionality is
+particularly useful for formulating Category Theory.  In Category
+theory it is also commonplace to identify isomorphic structures.
+Univalence gives us a way to make this notion precise.  In fact we can
+formulate this requirement within our formulation of categories by
+requiring the \emph{categories} themselves to be univalent as we shall
+see in section \S\ref{sec:univalence}.
+
+\section{Context}
+\label{sec:context}
+%
+The idea of formalizing Category Theory in proof assistants is not new.  There
+are a multitude of these available online.  Notably:
+%
+\begin{itemize}
+\item
+  A formalization in Agda using the setoid approach:
+  \url{https://github.com/copumpkin/categories}
+\item
+  A formalization in Agda with univalence and functional
+  extensionality as postulates:
+  \url{https://github.com/pcapriotti/agda-categories}
+\item
+  A formalization in Coq in the homotopic setting:
+  \url{https://github.com/HoTT/HoTT/tree/master/theories/Categories}
+\item
+  A formalization in \emph{CubicalTT} -- a language designed for
+  cubical type theory.  Formalizes many different things, but only a
+  few concepts from category theory:
+  \url{https://github.com/mortberg/cubicaltt}
+\end{itemize}
+%
+The contribution of this thesis is to explore how working in a cubical
+setting will make it possible to prove more things, to reuse proofs
+and to compare some aspects of this formalization with the existing
+ones.
+
+There are alternative approaches to working in a cubical setting where
+one can still have univalence and functional extensionality.  One
+option is to postulate these as axioms.  This approach, however, has
+other shortcomings, e.g.\ you lose \nomenindex{canonicity}
+(\cite[p.\ 3]{huber-2016}).
+
+Another approach is to use the \emph{setoid interpretation} of type
+theory (\cite{hofmann-1995,huber-2016}). With this approach one works
+with \nomenindex{extensional sets} $(X, \sim)$. That is a type $X \tp
+\MCU$ and an equivalence relation $\sim\ \tp X \to X \to \MCU$ on that
+type. Under the setoid interpretation the equivalence relation serve
+as a sort of ``local'' propositional equality. Since the developer
+gets to pick this relation, it is not a~priori a congruence
+relation. It must be manually verified by the developer.  Furthermore,
+functions between different setoids must be shown to be setoid
+homomorphism, that is; they preserve the relation.
+
+This approach has other drawbacks: It does not satisfy all
+propositional equalities of type theory a~priori. That is, the
+developer must manually show that e.g.\ the relation is a congruence.
+Equational proofs $a \sim_{X} b$ are in some sense `local' to the
+extensional set $(X , \sim)$. To e.g.\ prove that $x ∼ y → f\ x ∼
+f\ y$ for some function $f \tp A → B$ between two extensional sets $A$
+and $B$ it must be shown that $f$ is a groupoid homomorphism. This
+makes it very cumbersome to work with in practice (\cite[p.
+  4]{huber-2016}).
+
+\section{Conventions}
+In the remainder of this thesis I will use the term \nomenindex{Type}
+to describe -- well -- types; thereby departing from the notation in
+Agda where the keyword \texttt{Set} refers to types.
+\nomenindex{Set}, on the other hand, shall refer to the homotopical
+notion of a set. I will also leave all universe levels implicit. This
+of course does not mean that a statement such as $\MCU \tp \MCU$ means
+that we have type-in-type but rather that the arguments to the
+universes are implicit.
+
+I use the term \nomenindex{arrow} to refer to morphisms in a category,
+whereas the terms \nomenindex{morphism}, \nomenindex{map} or
+\nomenindex{function} shall be reserved for talking about type
+theoretic functions; i.e.\ functions in Agda.
+
+As already noted $\defeq$ will be used for introducing definitions $=$
+will be used to for judgmental equality and $\equiv$ will be used for
+propositional equality.
+
+All this is summarized in the following table:
+%
+\begin{samepage}
+\begin{center}
+\begin{tabular}{ c c c }
+Name & Agda & Notation \\
+\hline
+
+\varindex{Type}            & \texttt{Set}         & $\Type$            \\
+
+\varindex{Set}             & \texttt{Σ Set IsSet} & $\Set$             \\
+Function, morphism, map & \texttt{A → B}       & $A → B$            \\
+Dependent- ditto        & \texttt{(a : A) → B} & $∏_{a \tp A} B$  \\
+
+\varindex{Arrow}           & \texttt{Arrow A B}   & $\Arrow\ A\ B$     \\
+
+\varindex{Object}          & \texttt{C.Object}    & $̱ℂ.Object$     \\
+Definition              & \texttt{=}           & $̱\defeq$       \\
+Judgmental equality     & \null                & $̱=$            \\
+Propositional equality  & \null                & $̱\equiv$
+\end{tabular}
+\end{center}
+\end{samepage}

doc/macros.tex

@@ -0,0 +1,147 @@
+\newcommand{\subsubsubsection}[1]{\textbf{#1}}
+\newcommand{\WIP}{\textbf{WIP}}
+
+\newcommand{\coloneqq}{\mathrel{\vcenter{\baselineskip0.5ex \lineskiplimit0pt
+                     \hbox{\scriptsize.}\hbox{\scriptsize.}}}%
+  =}
+
+\newcommand{\defeq}{\mathrel{\triangleq}}
+%% Alternatively:
+%% \newcommand{\defeq}{≔}
+\newcommand{\bN}{\mathbb{N}}
+\newcommand{\bC}{ℂ}
+\newcommand{\bD}{𝔻}
+\newcommand{\bX}{𝕏}
+% \newcommand{\to}{\rightarrow}
+%% \newcommand{\mto}{\mapsto}
+\newcommand{\mto}{\rightarrow}
+\newcommand{\UU}{\ensuremath{\mathcal{U}}\xspace}
+\let\type\UU
+\newcommand{\MCU}{\UU}
+\newcommand{\todo}[1]{\textit{#1}}
+\newcommand{\comp}{\circ}
+\newcommand{\x}{\times}
+\newcommand\inv[1]{#1\raisebox{1.15ex}{$\scriptscriptstyle-\!1$}}
+\newcommand{\tp}{\mathrel{:}}
+\newcommand{\Type}{\mathcal{U}}
+
+\usepackage{graphicx}
+\makeatletter
+\newcommand{\shorteq}{%
+  \settowidth{\@tempdima}{-}% Width of hyphen
+  \resizebox{\@tempdima}{\height}{=}%
+}
+\makeatother
+\newcommand{\var}[1]{\ensuremath{\mathit{#1}}}
+\newcommand{\varindex}[1]{\ensuremath{\var{#1}}\index{$\var{#1}$}}
+\newcommand{\nomen}[2]{\emph{#1}\index{#2}}
+\newcommand{\nomenindex}[1]{\nomen{#1}{#1}}
+
+\newcommand{\Hom}{\varindex{Hom}}
+\newcommand{\fmap}{\varindex{fmap}}
+\newcommand{\bind}{\varindex{bind}}
+\newcommand{\join}{\varindex{join}}
+\newcommand{\omap}{\varindex{omap}}
+\newcommand{\pure}{\varindex{pure}}
+\newcommand{\idFun}{\varindex{id}}
+\newcommand{\Sets}{\varindex{Sets}}
+\newcommand{\Set}{\varindex{Set}}
+\newcommand{\hSet}{\varindex{hSet}}
+\newcommand{\id}{\varindex{id}}
+\newcommand{\isEquiv}{\varindex{isEquiv}}
+\newcommand{\idToIso}{\varindex{idToIso}}
+\newcommand{\idIso}{\varindex{idIso}}
+\newcommand{\isSet}{\varindex{isSet}}
+\newcommand{\isContr}{\varindex{isContr}}
+\newcommand{\isGroupoid}{\varindex{isGroupoid}}
+\newcommand{\pathJ}{\varindex{pathJ}}
+\newcommand\Object{\varindex{Object}}
+\newcommand\Functor{\varindex{Functor}}
+\newcommand\isProp{\varindex{isProp}}
+\newcommand\propPi{\varindex{propPi}}
+\newcommand\propSig{\varindex{propSig}}
+\newcommand\PreCategory{\varindex{PreCategory}}
+\newcommand\IsPreCategory{\varindex{IsPreCategory}}
+\newcommand\isIdentity{\varindex{isIdentity}}
+\newcommand\propIsIdentity{\varindex{propIsIdentity}}
+\newcommand\IsCategory{\varindex{IsCategory}}
+\newcommand\Gl{\varindex{\lambda}}
+\newcommand\lemPropF{\varindex{lemPropF}}
+\newcommand\isPreCategory{\varindex{isPreCategory}}
+\newcommand\congruence{\varindex{cong}}
+\newcommand\identity{\varindex{identity}}
+\newcommand\isequiv{\varindex{isequiv}}
+\newcommand\qinv{\varindex{qinv}}
+\newcommand\fiber{\varindex{fiber}}
+\newcommand\shufflef{\varindex{shuffle}}
+\newcommand\Univalent{\varindex{Univalent}}
+\newcommand\refl{\varindex{refl}}
+\newcommand\isoToId{\varindex{isoToId}}
+\newcommand\Isomorphism{\varindex{Isomorphism}}
+\newcommand\rrr{\ggg}
+%% \newcommand\fish{\mathbin{↣}}
+%% \newcommand\fish{\mathbin{⤅}}
+\newcommand\fish{\mathbin{⤇}}
+%% \newcommand\fish{\mathbin{⤜}}
+%% \newcommand\fish{\mathrel{\wideoverbar{\rrr}}}
+\newcommand\fst{\varindex{fst}}
+\newcommand\snd{\varindex{snd}}
+\newcommand\Path{\varindex{Path}}
+\newcommand\Category{\varindex{Category}}
+\newcommand\TODO[1]{TODO: \emph{#1}}
+\newcommand*{\QED}{\hfill\ensuremath{\square}}%
+\newcommand\uexists{\exists!}
+\newcommand\Arrow{\varindex{Arrow}}
+\newcommand\embellish[1]{\widehat{#1}}
+\newcommand\nattrans[1]{\embellish{#1}}
+\newcommand\functor[1]{\embellish{#1}}
+\newcommand\NTsym{\varindex{NT}}
+\newcommand\NT[2]{\NTsym\ #1\ #2}
+\newcommand\Endo[1]{\varindex{Endo}\ #1}
+\newcommand\EndoR{\functor{\mathcal{R}}}
+\newcommand\omapR{\mathcal{R}}
+\newcommand\omapF{\mathcal{F}}
+\newcommand\omapG{\mathcal{G}}
+\newcommand\FunF{\functor{\omapF}}
+\newcommand\FunG{\functor{\omapG}}
+\newcommand\funExt{\varindex{funExt}}
+\newcommand{\suc}[1]{\varindex{suc}\ #1}
+\newcommand{\trans}{\varindex{trans}}
+\newcommand{\toKleisli}{\varindex{toKleisli}}
+\newcommand{\toMonoidal}{\varindex{toMonoidal}}
+\newcommand\pairA{\mathcal{A}}
+\newcommand\pairB{\mathcal{B}}
+\newcommand{\joinNT}{\functor{\varindex{join}}}
+\newcommand{\pureNT}{\functor{\varindex{pure}}}
+\newcommand{\hrefsymb}[2]{\href{#1}{#2 \ExternalLink}}
+\newcommand{\sourcebasepath}{http://web.student.chalmers.se/\textasciitilde hanghj/cat/doc/html/}
+\newcommand{\docbasepath}{https://github.com/fredefox/cat/}
+\newcommand{\sourcelink}[1]{\hrefsymb
+    {\sourcebasepath#1.html}
+    {\texttt{#1}}
+  }
+\newcommand{\gitlink}{\hrefsymb{\docbasepath}{\texttt{\docbasepath}}}
+\newcommand{\doclink}{\hrefsymb{\sourcebasepath}{\texttt{\sourcebasepath}}}
+\newcommand{\clll}{\mathrel{\bC.\mathord{\lll}}}
+\newcommand{\dlll}{\mathrel{\bD.\mathord{\lll}}}
+\newcommand\coe{\varindex{coe}}
+\newcommand\Monoidal{\varindex{Monoidal}}
+\newcommand\Kleisli{\varindex{Kleisli}}
+\newcommand\I{\mathds{I}}
+
+\makeatletter
+\DeclareRobustCommand\bigop[1]{%
+  \mathop{\vphantom{\sum}\mathpalette\bigop@{#1}}\slimits@
+}
+\newcommand{\bigop@}[2]{%
+  \vcenter{%
+    \sbox\z@{$#1\sum$}%
+    \hbox{\resizebox{\ifx#1\displaystyle.7\fi\dimexpr\ht\z@+\dp\z@}{!}{$\m@th#2$}}%
+  }%
+}
+\makeatother
+
+\renewcommand{\llll}{\mathbin{\bigop{\lll}}}
+\renewcommand{\rrrr}{\mathbin{\bigop{\rrr}}}
+%% \newcommand{\llll}{lll}
+%% \newcommand{\rrrr}{rrr}

doc/main.tex

@@ -0,0 +1,76 @@
+\documentclass[a4paper]{report}
+%% \documentclass[tightpage]{preview}
+%% \documentclass[compact,a4paper]{article}
+
+\input{packages.tex}
+\input{macros.tex}
+
+\title{Univalent Categories}
+\author{Frederik Hanghøj Iversen}
+
+%% \usepackage[
+%%   subtitle=foo,
+%%   author=Frederik Hanghøj Iversen,
+%%   authoremail=hanghj@student.chalmers.se,
+%%   newcommand=chalmers,=Chalmers University of Technology,
+%%   supervisor=Thierry Coquand,
+%%   supervisoremail=coquand@chalmers.se,
+%%   supervisordepartment=chalmers,
+%%   cosupervisor=Andrea Vezzosi,
+%%   cosupervisoremail=vezzosi@chalmers.se,
+%%   cosupervisordepartment=chalmers,
+%%   examiner=Andreas Abel,
+%%   examineremail=abela@chalmers.se,
+%%   examinerdepartment=chalmers,
+%%   institution=chalmers,
+%%   department=Department of Computer Science and Engineering,
+%%   researchgroup=Programming Logic Group
+%%   ]{chalmerstitle}
+
+\usepackage{chalmerstitle}
+\subtitle{A formalization of category theory in Cubical Agda}
+\authoremail{hanghj@student.chalmers.se}
+\newcommand{\chalmers}{Chalmers University of Technology and University of Gothenburg}
+\supervisor{Thierry Coquand}
+\supervisoremail{coquand@chalmers.se}
+\supervisordepartment{\chalmers}
+\cosupervisor{Andrea Vezzosi}
+\cosupervisoremail{vezzosi@chalmers.se}
+\cosupervisordepartment{\chalmers}
+\examiner{Andreas Abel}
+\examineremail{abela@chalmers.se}
+\examinerdepartment{\chalmers}
+\institution{\chalmers}
+\department{Department of Computer Science and Engineering}
+\researchgroup{Programming Logic Group}
+
+\begin{document}
+
+\frontmatter
+\myfrontmatter
+\maketitle
+\input{abstract.tex}
+\input{acknowledgements.tex}
+\tableofcontents
+\mainmatter
+%
+\input{introduction.tex}
+\input{cubical.tex}
+\input{implementation.tex}
+\input{discussion.tex}
+\input{conclusion.tex}
+
+\nocite{cubical-demo}
+\nocite{coquand-2013}
+
+\bibliography{refs}
+\begin{appendices}
+\setcounter{page}{1}
+\pagenumbering{roman}
+\input{appendix/abstract-funext.tex}
+%% \input{sources.tex}
+%% \input{planning.tex}
+%% \input{halftime.tex}
+\end{appendices}
+\printindex
+\end{document}

doc/packages.tex

@@ -0,0 +1,151 @@
+\usepackage[utf8]{inputenc}
+
+\usepackage{natbib}
+\bibliographystyle{plain}
+
+\usepackage{xcolor}
+%% \mode<report>{
+\usepackage[
+  %% hidelinks,
+  pdfusetitle,
+  pdfsubject={category theory},
+  pdfkeywords={type theory, homotopy theory, category theory, agda}]
+  {hyperref}
+%% }
+%% \definecolor{darkorange}{HTML}{ff8c00}
+%% \hypersetup{allbordercolors={darkorange}}
+\hypersetup{hidelinks}
+\usepackage{graphicx}
+%% \usepackage[active,tightpage]{preview}
+
+\usepackage{parskip}
+\usepackage{multicol}
+\usepackage{amssymb,amsmath,amsthm,stmaryrd,mathrsfs,wasysym}
+\usepackage[toc,page]{appendix}
+\usepackage{xspace}
+\usepackage[paper=a4paper,top=3cm,bottom=3cm]{geometry}
+\usepackage{makeidx}
+\makeindex
+% \setlength{\parskip}{10pt}
+
+% \usepackage{tikz}
+% \usetikzlibrary{arrows, decorations.markings}
+
+% \usepackage{chngcntr}
+% \counterwithout{figure}{section}
+\numberwithin{equation}{section}
+
+\usepackage{listings}
+\usepackage{fancyvrb}
+
+\usepackage{mathpazo}
+\usepackage[scaled=0.95]{helvet}
+\usepackage{courier}
+\linespread{1.05} % Palatino looks better with this
+
+\usepackage{lmodern}
+
+\usepackage{enumerate}
+\usepackage{verbatim}
+
+\usepackage{fontspec}
+\usepackage[light]{sourcecodepro}
+%% \setmonofont{Latin Modern Mono}
+%% \setmonofont[Mapping=tex-text]{FreeMono.otf}
+%% \setmonofont{FreeMono.otf}
+
+
+%% \pagestyle{fancyplain}
+\setlength{\headheight}{15pt}
+\renewcommand{\chaptermark}[1]{\markboth{\textsc{Chapter \thechapter. #1}}{}}
+\renewcommand{\sectionmark}[1]{\markright{\textsc{\thesection\ #1}}}
+
+% Allows for the use of unicode-letters:
+\usepackage{unicode-math}
+
+%% \RequirePackage{kvoptions}
+
+\usepackage{pgffor}
+\lstset
+  {basicstyle=\ttfamily
+  ,columns=fullflexible
+  ,breaklines=true
+  ,inputencoding=utf8
+  ,extendedchars=true
+  %% ,literate={á}{{\'a}}1 {ã}{{\~a}}1 {é}{{\'e}}1
+  }
+  
+\usepackage{newunicodechar}
+
+%% \setmainfont{PT Serif}
+\newfontfamily{\fallbackfont}{FreeMono.otf}[Scale=MatchLowercase]
+%% \setmonofont[Mapping=tex-text]{FreeMono.otf}
+\DeclareTextFontCommand{\textfallback}{\fallbackfont}
+\newunicodechar{∨}{\textfallback{∨}}
+\newunicodechar{∧}{\textfallback{∧}}
+\newunicodechar{⊔}{\textfallback{⊔}}
+%% \newunicodechar{≊}{\textfallback{≊}}
+\newunicodechar{∈}{\textfallback{∈}}
+\newunicodechar{ℂ}{\textfallback{ℂ}}
+\newunicodechar{∘}{\textfallback{∘}}
+\newunicodechar{⟨}{\textfallback{⟨}}
+\newunicodechar{⟩}{\textfallback{⟩}}
+\newunicodechar{∎}{\textfallback{∎}}
+%% \newunicodechar{𝒜}{\textfallback{𝒜}}
+%% \newunicodechar{ℬ}{\textfallback{ℬ}}
+%% \newunicodechar{≊}{\textfallback{≊}}
+\makeatletter
+\newcommand*{\rom}[1]{\expandafter\@slowroman\romannumeral #1@}
+\makeatother
+\makeatletter
+
+\newcommand\frontmatter{%
+    \cleardoublepage
+  %\@mainmatterfalse
+  \pagenumbering{roman}}
+
+\newcommand\mainmatter{%
+    \cleardoublepage
+ % \@mainmattertrue
+  \pagenumbering{arabic}}
+
+\newcommand\backmatter{%
+  \if@openright
+    \cleardoublepage
+  \else
+    \clearpage
+  \fi
+ % \@mainmatterfalse
+   }
+
+\makeatother
+\usepackage{xspace}
+\usepackage{tikz}
+\newcommand{\ExternalLink}{%
+    \tikz[x=1.2ex, y=1.2ex, baseline=-0.05ex]{% 
+        \begin{scope}[x=1ex, y=1ex]
+            \clip (-0.1,-0.1) 
+                --++ (-0, 1.2) 
+                --++ (0.6, 0) 
+                --++ (0, -0.6) 
+                --++ (0.6, 0) 
+                --++ (0, -1);
+            \path[draw, 
+                line width = 0.5, 
+                rounded corners=0.5] 
+                (0,0) rectangle (1,1);
+        \end{scope}
+        \path[draw, line width = 0.5] (0.5, 0.5) 
+            -- (1, 1);
+        \path[draw, line width = 0.5] (0.6, 1) 
+            -- (1, 1) -- (1, 0.6);
+        }
+    }
+\usepackage{ dsfont }
+
+\usepackage{eso-pic}
+\newcommand{\backgroundpic}[3]{
+	\put(#1,#2){
+	\parbox[b][\paperheight]{\paperwidth}{
+	\centering
+	\includegraphics[width=\paperwidth,height=\paperheight,keepaspectratio]{#3}}}}

doc/planning.tex

@@ -0,0 +1,72 @@
+\chapter{Planning report}
+%
+I have already implemented multiple essential building blocks for a
+formalization of core-category theory. These concepts include:
+%
+\begin{itemize}
+\item
+Categories
+\item
+Functors
+\item
+Products
+\item
+Exponentials
+\item
+Natural transformations
+\item
+Concrete Categories
+\subitem
+Sets
+\subitem
+Cat
+\subitem
+Functor
+\end{itemize}
+%
+Will all these things already in place it's my assessment that I am ahead of
+schedule at this point.\footnote{I have omitted a lot of other things that
+  follow easily from the above, e.g. a cartesian-closed category is simply one
+  that has all products and exponentials.}
+
+Here is a plan for my thesis work organized on a week-by-week basis.
+%
+\begin{center}
+\centering
+\begin{tabular}{@{}lll@{}}
+Goal                           & Deadline    & Risk  1-5        \\ \hline
+Yoneda embedding               & Feb 2nd     & 3  \\
+Categories with families       & Feb 9th     & 4  \\
+Presheafs $\Rightarrow$ CwF's  & Feb 16th    & 2  \\
+Cubical Category               & Feb 23rd    & 3  \\
+Writing seminar                & Mar 2nd     &    \\
+Kan condition                  & Mar 9th     & 4  \\
+Thesis outline and backlog     & Mar 16th    & 2  \\
+Half-time report               & Mar 23rd    & 2  \\
+                               & Mar 30th    &    \\
+                               & Apr 6th     &    \\
+                               & Apr 13th    &    \\
+                               & Apr  20th   &    \\
+Thesis draft                   & Apr 27th    & 2  \\
+Writing seminar 2              & May 4th     &    \\
+Presentation                   & May 11th    &    \\
+Attend 1st presentation        & May 18th    &    \\
+Attend 2nd presentation        & May 25th    &    \\
+\end{tabular}
+\end{center}
+%
+The first half part of my thesis-work will be focused on implementing core
+elements of my Agda implementation. These core elements have been highlighted in
+the above table. The elements noted there are the essential bits and pieces I
+need to reach the ambitious goal of getting an implementation of a categorical
+model for Cubical Type Theory. Along the way I will also have formalized
+additional elements of more ``pure'' category theory. I will thus reach my goal
+of formalizing (parts of) category theory.
+
+The high risk-factors for CwF's and the Kan-condition is due to this being
+somewhat uncharted territory for me at this point.
+
+It's my plan that I will have formalized the core concepts needed around the
+deadline for the half-time report which is due by March 23rd. Around this point
+I will have a clearer idea of what additional things I need for a model of
+category theory.

doc/presentation.tex

@@ -0,0 +1,492 @@
+\documentclass[a4paper]{beamer}
+%% \documentclass[a4paper,handout]{beamer}
+%% \usecolortheme[named=seagull]{structure}
+
+\input{packages.tex}
+
+\input{macros.tex}
+
+\title{Univalent Categories}
+\subtitle{A formalization of category theory in Cubical Agda}
+
+\newcommand{\myname}{Frederik Hangh{\o}j Iversen}
+\author[\myname]{
+  \myname\\
+  \footnotesize Supervisors: Thierry Coquand, Andrea Vezzosi\\
+  Examiner: Andreas Abel
+}
+\institute{Chalmers University of Technology}
+
+\begin{document}
+
+\frame{\titlepage}
+
+\begin{frame}
+\frametitle{Introduction}
+Category Theory: The study of abstract functions. Slogan: ``It's the
+arrows that matter''\pause
+
+Objects are equal ``up to isomorphism''.  Univalence makes this notion
+precise.\pause
+
+Agda does not permit proofs of univalence.  Cubical Agda admits
+this.\pause
+
+Goal: Construct a category whose terminal objects are (equivalent to)
+products. Use this to conclude that products are propositions, not a
+structure on a category.
+\end{frame}
+
+\begin{frame}
+\frametitle{Outline}
+The path type
+
+Definition of a (pre-) category
+
+1-categories
+
+Univalent (proper) categories
+
+The category of spans
+\end{frame}
+
+\section{Paths}
+\begin{frame}
+  \frametitle{Paths}
+  \framesubtitle{Definition}
+  Heterogeneous paths
+  \begin{equation*}
+    \Path \tp (P \tp \I → \MCU) → P\ 0 → P\ 1 → \MCU
+  \end{equation*}
+  \pause
+  For $P \tp \I → \MCU$ and $a_0 \tp P\ 0$, $a_1 \tp P\ 1$
+  inhabitants of $\Path\ P\ a_0\ a_1$ are like functions
+  %
+  $$
+  p \tp ∏_{i \tp \I} P\ i
+  $$
+  %
+  Which satisfy $p\ 0 & = a_0$ and $p\ 1 & = a_1$
+  \pause
+
+  Homogenous paths
+  $$
+  a_0 ≡ a_1 ≜ \Path\ (\var{const}\ A)\ a_0\ a_1
+  $$
+\end{frame}
+
+\begin{frame}
+  \frametitle{Pre categories}
+  \framesubtitle{Definition}
+  Data:
+  \begin{align*}
+    \Object   & \tp \Type \\
+    \Arrow    & \tp \Object → \Object → \Type \\
+    \identity & \tp \Arrow\ A\ A \\
+    \llll      & \tp \Arrow\ B\ C → \Arrow\ A\ B → \Arrow\ A\ C
+  \end{align*}
+  %
+  \pause
+  Laws:
+  %
+  \begin{align*}
+  \var{isAssociative} & \tp
+  h \llll (g \llll f) ≡ (h \llll g) \llll f \\
+  \var{isIdentity} & \tp
+  (\identity \llll f ≡ f)
+  ×
+  (f \llll \identity ≡ f)
+  \end{align*}
+
+\end{frame}
+\begin{frame}
+  \frametitle{Pre categories}
+  \framesubtitle{1-categories}
+Cubical Agda does not admit \emph{Uniqueness of Identity Proofs}
+(UIP).  Rather there is a hierarchy of \emph{Homotopy Types}:
+Contractible types, mere propositions, sets, groupoids, \dots
+
+\pause
+  1-categories:
+  $$
+  \isSet\ (\Arrow\ A\ B)
+  $$
+\pause
+  \begin{align*}
+    \isSet    & \tp \MCU → \MCU \\
+    \isSet\ A & ≜ ∏_{a_0, a_1 \tp A} \isProp\ (a_0 ≡ a_1)
+  \end{align*}
+\end{frame}
+
+\begin{frame}
+\frametitle{Outline}
+The path type \ensuremath{\checkmark}
+
+Definition of a (pre-) category \ensuremath{\checkmark}
+
+1-categories \ensuremath{\checkmark}
+
+Univalent (proper) categories
+
+The category of spans
+\end{frame}
+
+\begin{frame}
+  \frametitle{Categories}
+  \framesubtitle{Univalence}
+  Let $\approxeq$ denote isomorphism of objects.  We can then construct
+  the identity isomorphism in any category:
+  $$
+  (\identity , \identity , \var{isIdentity}) \tp A \approxeq A
+  $$
+  \pause
+  Likewise since paths are substitutive we can promote a path to an isomorphism:
+  $$
+  \idToIso \tp A ≡ B → A ≊ B
+  $$
+  \pause
+  For a category to be univalent we require this to be an equivalence:
+  %
+  $$
+  \isEquiv\ (A ≡ B)\ (A \approxeq B)\ \idToIso
+  $$
+  %
+\end{frame}
+\begin{frame}
+  \frametitle{Categories}
+  \framesubtitle{Univalence, cont'd}
+  $$\isEquiv\ (A ≡ B)\ (A \approxeq B)\ \idToIso$$
+  \pause%
+  $$(A ≡ B) ≃ (A \approxeq B)$$
+  \pause%
+  $$(A ≡ B) ≅ (A \approxeq B)$$
+  \pause%
+  Name the inverse of $\idToIso$:
+  $$\isoToId \tp (A \approxeq B) → (A ≡ B)$$
+\end{frame}
+\begin{frame}
+  \frametitle{Propositionality of products}
+  Construct a category for which it is the case that the terminal
+  objects are equivalent to products:
+  \begin{align*}
+    \var{Terminal} ≃ \var{Product}\ ℂ\ 𝒜\ ℬ
+  \end{align*}
+
+  \pause
+  And since equivalences preserve homotopy levels we get:
+  %
+  $$
+  \isProp\ \left(\var{Product}\ \bC\ 𝒜\ ℬ\right)
+  $$
+\end{frame}
+
+\begin{frame}
+  \frametitle{Categories}
+  \framesubtitle{A theorem}
+  %
+  Let the isomorphism $(ι, \inv{ι}, \var{inv}) \tp A \approxeq B$.
+  %
+  \pause
+  %
+  The isomorphism induces the path
+  %
+  $$
+  p ≜ \isoToId\ (\iota, \inv{\iota}, \var{inv}) \tp A ≡ B
+  $$
+  %
+  \pause
+  and consequently a path on arrows:
+  %
+  $$
+  p_{\var{dom}} ≜ \congruence\ (λ x → \Arrow\ x\ X)\ p
+  \tp
+  \Arrow\ A\ X ≡ \Arrow\ B\ X
+  $$
+  %
+  \pause
+  The proposition is:
+  %
+  \begin{align}
+    \label{eq:coeDom}
+    \tag{$\var{coeDom}$}
+    ∏_{f \tp A → X}
+    \var{coe}\ p_{\var{dom}}\ f ≡ f \llll \inv{\iota}
+  \end{align}
+\end{frame}
+\begin{frame}
+  \frametitle{Categories}
+  \framesubtitle{A theorem, proof}
+  \begin{align*}
+    \var{coe}\ p_{\var{dom}}\ f
+    & ≡ f \llll (\idToIso\ p)_1 && \text{By path-induction} \\
+    & ≡ f \llll \inv{\iota}
+    && \text{$\idToIso$ and $\isoToId$ are inverses}\\
+  \end{align*}
+  \pause
+  %
+  Induction will be based at $A$.  Let $\widetilde{B}$ and $\widetilde{p}
+  \tp A ≡ \widetilde{B}$ be given.
+  %
+  \pause
+  %
+  Define the family:
+  %
+  $$
+  D\ \widetilde{B}\ \widetilde{p} ≜
+  \var{coe}\ \widetilde{p}_{\var{dom}}\ f
+  ≡
+  f \llll \inv{(\idToIso\ \widetilde{p})}
+  $$
+  \pause
+  %
+  The base-case becomes:
+  $$
+  d \tp D\ A\ \refl =
+  \left(\var{coe}\ \refl_{\var{dom}}\ f ≡ f \llll \inv{(\idToIso\ \refl)}\right)
+  $$
+\end{frame}
+\begin{frame}
+  \frametitle{Categories}
+  \framesubtitle{A theorem, proof, cont'd}
+  $$
+  d \tp
+  \var{coe}\ \refl_{\var{dom}}\ f ≡ f \llll \inv{(\idToIso\ \refl)}
+  $$
+  \pause
+  \begin{align*}
+    \var{coe}\ \refl_{\var{dom}}\ f
+    & =
+    \var{coe}\ \refl\ f \\
+    & ≡ f
+    && \text{neutral element for $\var{coe}$}\\
+    & ≡ f \llll \identity \\
+    & ≡ f \llll \var{subst}\ \refl\ \identity
+    && \text{neutral element for $\var{subst}$}\\
+    & ≡ f \llll \inv{(\idToIso\ \refl)}
+    && \text{By definition of $\idToIso$}\\
+  \end{align*}
+  \pause
+  In conclusion, the theorem is inhabited by:
+  $$
+  \var{pathInd}\ D\ d\ B\ p
+  $$
+\end{frame}
+\begin{frame}
+  \frametitle{Span category} \framesubtitle{Definition} Given a base
+  category $\bC$ and two objects in this category $\pairA$ and $\pairB$
+  we can construct the \nomenindex{span category}:
+  %
+  \pause
+  Objects:
+  $$
+  ∑_{X \tp Object} (\Arrow\ X\ \pairA) × (\Arrow\ X\ \pairB)
+  $$
+  \pause
+  %
+  Arrows between objects $(A , a_{\pairA} , a_{\pairB})$ and
+  $(B , b_{\pairA} , b_{\pairB})$:
+  %
+  $$
+  ∑_{f \tp \Arrow\ A\ B}
+  (b_{\pairA} \llll f ≡ a_{\pairA}) ×
+  (b_{\pairB} \llll f ≡ a_{\pairB})
+  $$
+\end{frame}
+\begin{frame}
+  \frametitle{Span category}
+  \framesubtitle{Univalence}
+  \begin{align*}
+    (X , x_{𝒜} , x_{ℬ}) ≡ (Y , y_{𝒜} , y_{ℬ})
+  \end{align*}
+  \begin{align*}
+    \begin{split}
+      p \tp & X ≡ Y \\
+      & \Path\ (λ i → \Arrow\ (p\ i)\ 𝒜)\ x_{𝒜}\ y_{𝒜} \\
+      & \Path\ (λ i → \Arrow\ (p\ i)\ ℬ)\ x_{ℬ}\ y_{ℬ}
+    \end{split}
+  \end{align*}
+  \begin{align*}
+    \begin{split}
+      \var{iso} \tp & X \approxeq Y \\
+      & \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ 𝒜)\ x_{𝒜}\ y_{𝒜} \\
+      & \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ ℬ)\ x_{ℬ}\ y_{ℬ}
+    \end{split}
+  \end{align*}
+  \begin{align*}
+    (X , x_{𝒜} , x_{ℬ}) ≊ (Y , y_{𝒜} , y_{ℬ})
+  \end{align*}
+\end{frame}
+\begin{frame}
+  \frametitle{Span category}
+  \framesubtitle{Univalence, proof}
+  %
+  \begin{align*}
+    %% (f, \inv{f}, \var{inv}_f, \var{inv}_{\inv{f}})
+    %% \tp
+    (X, x_{𝒜}, x_{ℬ}) \approxeq (Y, y_{𝒜}, y_{ℬ})
+    \to
+    \begin{split}
+      \var{iso} \tp & X \approxeq Y \\
+      & \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ 𝒜)\ x_{𝒜}\ y_{𝒜} \\
+      & \Path\ (λ i → \Arrow\ (\widetilde{p}\ i)\ ℬ)\ x_{ℬ}\ y_{ℬ}
+    \end{split}
+  \end{align*}
+  \pause
+  %
+  Let $(f, \inv{f}, \var{inv}_f, \var{inv}_{\inv{f}})$ be an inhabitant
+  of the antecedent.\pause
+
+  Projecting out the first component gives us the isomorphism
+  %
+  $$
+  (\fst\ f, \fst\ \inv{f}
+  , \congruence\ \fst\ \var{inv}_f
+  , \congruence\ \fst\ \var{inv}_{\inv{f}}
+  )
+  \tp X \approxeq Y
+  $$
+  \pause
+  %
+  This gives rise to the following paths:
+  %
+  \begin{align*}
+    \begin{split}
+      \widetilde{p} & \tp X ≡ Y \\
+      \widetilde{p}_{𝒜} & \tp \Arrow\ X\ 𝒜 ≡ \Arrow\ Y\ 𝒜 \\
+    \end{split}
+  \end{align*}
+  %
+\end{frame}
+\begin{frame}
+  \frametitle{Span category}
+  \framesubtitle{Univalence, proof, cont'd}
+  It remains to construct:
+  %
+  \begin{align*}
+    \begin{split}
+      & \Path\ (λ i → \widetilde{p}_{𝒜}\ i)\ x_{𝒜}\ y_{𝒜}
+    \end{split}
+  \end{align*}
+  \pause
+  %
+  This is achieved with the following lemma:
+  %
+  \begin{align*}
+    ∏_{q \tp A ≡ B} \var{coe}\ q\ x_{𝒜} ≡ y_{𝒜}
+    →
+    \Path\ (λ i → q\ i)\ x_{𝒜}\ y_{𝒜}
+  \end{align*}
+  %
+  Which is used without proof.\pause
+
+  So the construction reduces to:
+  %
+  \begin{align*}
+    \var{coe}\ \widetilde{p}_{𝒜}\ x_{𝒜} ≡ y_{𝒜}
+  \end{align*}%
+  \pause%
+  This is proven with:
+  %
+  \begin{align*}
+    \var{coe}\ \widetilde{p}_{𝒜}\ x_{𝒜}
+    & ≡ x_{𝒜} \llll \fst\ \inv{f} && \text{\ref{eq:coeDom}} \\
+    & ≡ y_{𝒜} && \text{Property of span category}
+  \end{align*}
+\end{frame}
+\begin{frame}
+  \frametitle{Propositionality of products}
+  We have
+  %
+  $$
+  \isProp\ \var{Terminal}
+  $$\pause
+  %
+  We can show:
+  \begin{align*}
+    \var{Terminal} ≃ \var{Product}\ ℂ\ 𝒜\ ℬ
+  \end{align*}
+  \pause
+  And since equivalences preserve homotopy levels we get:
+  %
+  $$
+  \isProp\ \left(\var{Product}\ \bC\ 𝒜\ ℬ\right)
+  $$
+\end{frame}
+\begin{frame}
+  \frametitle{Monads}
+  \framesubtitle{Monoidal form}
+  %
+  \begin{align*}
+    \EndoR  & \tp \Functor\ ℂ\ ℂ \\
+    \pureNT
+    & \tp \NT{\widehat{\identity}}{\EndoR} \\
+    \joinNT
+    & \tp \NT{(\EndoR \oplus \EndoR)}{\EndoR}
+  \end{align*}
+  \pause
+  %
+  Let $\fmap$ be the map on arrows of $\EndoR$.
+  %
+  \begin{align*}
+    \join \llll \fmap\ \join
+    & ≡ \join \llll \join \\
+    \join \llll \pure\           & ≡ \identity \\
+    \join \llll \fmap\     \pure & ≡ \identity
+  \end{align*}
+\end{frame}
+\begin{frame}
+  \frametitle{Monads}
+  \framesubtitle{Kleisli form}
+  %
+  \begin{align*}
+    \omapR & \tp \Object → \Object \\
+    \pure  & \tp % ∏_{X \tp Object}
+    \Arrow\ X\ (\omapR\ X) \\
+    \bind  & \tp
+    \Arrow\ X\ (\omapR\ Y)
+    \to
+    \Arrow\ (\omapR\ X)\ (\omapR\ Y)
+  \end{align*}\pause
+  %
+  \begin{align*}
+    \fish & \tp
+    \Arrow\ A\ (\omapR\ B)
+    →
+    \Arrow\ B\ (\omapR\ C)
+    →
+    \Arrow\ A\ (\omapR\ C) \\
+    f \fish g & ≜ f \rrrr (\bind\ g)
+  \end{align*}
+  \pause
+  %
+  \begin{align*}
+    \bind\ \pure & ≡ \identity_{\omapR\ X} \\
+    \pure \fish f & ≡ f \\
+    (\bind\ f) \rrrr (\bind\ g) & ≡ \bind\ (f \fish g)
+  \end{align*}
+\end{frame}
+\begin{frame}
+  \frametitle{Monads}
+  \framesubtitle{Equivalence}
+  In the monoidal formulation we can define $\bind$:
+  %
+  $$
+  \bind\ f ≜ \join \llll \fmap\ f
+  $$
+  \pause
+  %
+  And likewise in the Kleisli formulation we can define $\join$:
+  %
+  $$
+  \join ≜ \bind\ \identity
+  $$
+  \pause
+  The laws are logically equivalent. Since logical equivalence is
+  enough for as an equivalence of types for propositions we get:
+  %
+  $$
+  \var{Monoidal} ≃ \var{Kleisli}
+  $$
+  %
+\end{frame}
+\end{document}

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}}
 }

doc/sources.tex

@@ -0,0 +1,429 @@
+\chapter{Source code excerpts}
+\label{ch:app-sources}
+In the following a few of the definitions mentioned in the report are included.
+The following is \emph{not} a verbatim copy of individual modules from the
+implementation. Rather, this is a redacted and pre-formatted designed for
+presentation purposes. Its provided here as a convenience. The actual sources
+are the only authoritative source. Is something is not clear, please refer to
+those.
+\section{Cubical}
+\label{sec:app-cubical}
+\begin{figure}[h]
+\label{fig:path}
+\begin{Verbatim}
+postulate
+  PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ
+
+module _ {ℓ} {A : Set ℓ} where
+  _≡_ : A → A → Set ℓ
+  _≡_ {A = A} = PathP (λ _ → A)
+
+  refl : {x : A} → x ≡ x
+  refl {x = x} = λ _ → x
+\end{Verbatim}
+\caption{Excerpt from the cubical library. Definition of the path-type.}
+\end{figure}
+\clearpage
+%
+\begin{figure}[h]
+\begin{Verbatim}
+module _ {ℓ : Level} (A : Set ℓ) where
+  isContr : Set ℓ
+  isContr = Σ[ x ∈ A ] (∀ y → x ≡ y)
+
+  isProp  : Set ℓ
+  isProp  = (x y : A) → x ≡ y
+
+  isSet   : Set ℓ
+  isSet   = (x y : A) → (p q : x ≡ y) → p ≡ q
+
+  isGrpd  : Set ℓ
+  isGrpd  = (x y : A) → (p q : x ≡ y) → (a b : p ≡ q) → a ≡ b
+\end{Verbatim}
+\caption{Excerpt from the cubical library. Definition of the first few
+  homotopy-levels.}
+\end{figure}
+%
+\begin{figure}[h]
+\begin{Verbatim}
+module _ {ℓ ℓ'} {A : Set ℓ} {x : A}
+         (P : ∀ y → x ≡ y → Set ℓ') (d : P x ((λ i → x))) where
+  pathJ : (y : A) → (p : x ≡ y) → P y p
+  pathJ _ p = transp (λ i → uncurry P (contrSingl p i)) d
+\end{Verbatim}
+\clearpage
+\caption{Excerpt from the cubical library. Definition of based path-induction.}
+\end{figure}
+%
+\begin{figure}[h]
+\begin{Verbatim}
+module _ {ℓ ℓ'} {A : Set ℓ} {B : A → Set ℓ'} where
+  propPi : (h : (x : A) → isProp (B x)) → isProp ((x : A) → B x)
+  propPi h f0 f1  = λ i → λ x → (h x (f0 x) (f1 x)) i
+
+  lemPropF : (P : (x : A) → isProp (B x)) {a0 a1 : A}
+    (p : a0 ≡ a1) {b0 : B a0} {b1 : B a1} → PathP (λ i → B (p i)) b0 b1
+  lemPropF P p {b0} {b1} = λ i → P (p i)
+     (primComp (λ j → B (p (i ∧ j)) ) (~ i) (λ _ →  λ { (i = i0) → b0 }) b0)
+     (primComp (λ j → B (p (i ∨ ~ j)) ) (i) (λ _ → λ{ (i = i1) → b1 }) b1) i
+
+  lemSig : (pB : (x : A) → isProp (B x))
+    (u v : Σ A B) (p : fst u ≡ fst v) → u ≡ v
+  lemSig pB u v p = λ i → (p i) , ((lemPropF pB p) {snd u} {snd v} i)
+
+  propSig : (pA : isProp A) (pB : (x : A) → isProp (B x)) → isProp (Σ A B)
+  propSig pA pB t u = lemSig pB t u (pA (fst t) (fst u))
+\end{Verbatim}
+\caption{Excerpt from the cubical library. A few combinators.}
+\end{figure}
+\clearpage
+\section{Categories}
+\label{sec:app-categories}
+\begin{figure}[h]
+\begin{Verbatim}
+record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
+  field
+    Object   : Set ℓa
+    Arrow    : Object → Object → Set ℓb
+    identity : {A : Object} → Arrow A A
+    _<<<_    : {A B C : Object} → Arrow B C → Arrow A B → Arrow A C
+
+  _>>>_ : {A B C : Object} → (Arrow A B) → (Arrow B C) → Arrow A C
+  f >>> g = g <<< f
+
+  IsAssociative : Set (ℓa ⊔ ℓb)
+  IsAssociative = ∀ {A B C D} {f : Arrow A B} {g : Arrow B C} {h : Arrow C D}
+    → h <<< (g <<< f) ≡ (h <<< g) <<< f
+
+  IsIdentity : ({A : Object} → Arrow A A) → Set (ℓa ⊔ ℓb)
+  IsIdentity id = {A B : Object} {f : Arrow A B}
+    → id <<< f ≡ f × f <<< id ≡ f
+
+  ArrowsAreSets : Set (ℓa ⊔ ℓb)
+  ArrowsAreSets = ∀ {A B : Object} → isSet (Arrow A B)
+
+  IsInverseOf : ∀ {A B} → (Arrow A B) → (Arrow B A) → Set ℓb
+  IsInverseOf = λ f g → g <<< f ≡ identity × f <<< g ≡ identity
+
+  Isomorphism : ∀ {A B} → (f : Arrow A B) → Set ℓb
+  Isomorphism {A} {B} f = Σ[ g ∈ Arrow B A ] IsInverseOf f g
+
+  _≊_ : (A B : Object) → Set ℓb
+  _≊_ A B = Σ[ f ∈ Arrow A B ] (Isomorphism f)
+
+  IsTerminal : Object → Set (ℓa ⊔ ℓb)
+  IsTerminal T = {X : Object} → isContr (Arrow X T)
+
+  Terminal : Set (ℓa ⊔ ℓb)
+  Terminal = Σ Object IsTerminal
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category}. The definition of a category.}
+\end{figure}
+\clearpage
+\begin{figure}[h]
+\begin{Verbatim}
+module Univalence (isIdentity : IsIdentity identity) where
+  idIso : (A : Object) → A ≊ A
+  idIso A = identity , identity , isIdentity
+
+  idToIso : (A B : Object) → A ≡ B → A ≊ B
+  idToIso A B eq = subst eq (idIso A)
+
+  Univalent : Set (ℓa ⊔ ℓb)
+  Univalent = {A B : Object} → isEquiv (A ≡ B) (A ≊ B) (idToIso A B)
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category}. Continued from previous. Definition of univalence.}
+\end{figure}
+\begin{figure}[h]
+\begin{Verbatim}
+module _ {ℓa ℓb : Level} (ℂ : RawCategory ℓa ℓb) where
+  record IsPreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
+    open RawCategory ℂ public
+    field
+      isAssociative : IsAssociative
+      isIdentity    : IsIdentity identity
+      arrowsAreSets : ArrowsAreSets
+    open Univalence isIdentity public
+
+  record PreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
+    field
+      isPreCategory  : IsPreCategory
+    open IsPreCategory isPreCategory public
+
+  record IsCategory : Set (lsuc (ℓa ⊔ ℓb)) where
+    field
+      isPreCategory : IsPreCategory
+    open IsPreCategory isPreCategory public
+    field
+      univalent : Univalent
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category}. Records with inhabitants for
+  the laws defined in the previous listings.}
+\end{figure}
+\clearpage
+\begin{figure}[h]
+\begin{Verbatim}
+module Opposite {ℓa ℓb : Level} where
+  module _ (ℂ : Category ℓa ℓb) where
+    private
+      module _ where
+        module ℂ = Category ℂ
+        opRaw : RawCategory ℓa ℓb
+        RawCategory.Object   opRaw = ℂ.Object
+        RawCategory.Arrow    opRaw = flip ℂ.Arrow
+        RawCategory.identity opRaw = ℂ.identity
+        RawCategory._<<<_    opRaw = ℂ._>>>_
+
+        open RawCategory opRaw
+
+        isPreCategory : IsPreCategory opRaw
+        IsPreCategory.isAssociative isPreCategory = sym ℂ.isAssociative
+        IsPreCategory.isIdentity    isPreCategory = swap ℂ.isIdentity
+        IsPreCategory.arrowsAreSets isPreCategory = ℂ.arrowsAreSets
+
+      open IsPreCategory isPreCategory
+
+      ----------------------------
+      -- NEXT LISTING GOES HERE --
+      ----------------------------
+
+      isCategory : IsCategory opRaw
+      IsCategory.isPreCategory isCategory = isPreCategory
+      IsCategory.univalent     isCategory
+        = univalenceFromIsomorphism (isoToId* , inv)
+
+    opposite : Category ℓa ℓb
+    Category.raw        opposite = opRaw
+    Category.isCategory opposite = isCategory
+
+  module _ {ℂ : Category ℓa ℓb} where
+    open Category ℂ
+    private
+      rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw
+      RawCategory.Object   (rawInv _) = Object
+      RawCategory.Arrow    (rawInv _) = Arrow
+      RawCategory.identity (rawInv _) = identity
+      RawCategory._<<<_    (rawInv _) = _<<<_
+
+    oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ
+    oppositeIsInvolution = Category≡ rawInv
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category}. Showing that the opposite
+  category is a category. Part of this listing has been cut out and placed in
+  the next listing.}
+\end{figure}
+\clearpage
+For reasons of formatting the following listing is continued from the above with
+fewer levels of indentation.
+%
+\begin{figure}[h]
+\begin{Verbatim}
+module _ {A B : ℂ.Object} where
+  open Σ (toIso _ _ (ℂ.univalent {A} {B}))
+    renaming (fst to idToIso* ; snd to inv*)
+  open AreInverses {f = ℂ.idToIso A B} {idToIso*} inv*
+
+  shuffle : A ≊ B → A ℂ.≊ B
+  shuffle (f , g , inv) = g , f , inv
+
+  shuffle~ : A ℂ.≊ B → A ≊ B
+  shuffle~ (f , g , inv) = g , f , inv
+
+  isoToId* : A ≊ B → A ≡ B
+  isoToId* = idToIso* ∘ shuffle
+
+  inv : AreInverses (idToIso A B) isoToId*
+  inv =
+    ( funExt (λ x → begin
+      (isoToId* ∘ idToIso A B) x
+        ≡⟨⟩
+      (idToIso* ∘ shuffle ∘ idToIso A B) x
+        ≡⟨ cong (λ φ → φ x)
+          (cong (λ φ → idToIso* ∘ shuffle ∘ φ) (funExt (isoEq refl))) ⟩
+      (idToIso* ∘ shuffle ∘ shuffle~ ∘ ℂ.idToIso A B) x
+        ≡⟨⟩
+      (idToIso* ∘ ℂ.idToIso A B) x
+        ≡⟨ (λ i → verso-recto i x) ⟩
+      x ∎)
+    , funExt (λ x → begin
+      (idToIso A B ∘ idToIso* ∘ shuffle) x
+        ≡⟨ cong (λ φ → φ x)
+          (cong (λ φ → φ ∘ idToIso* ∘ shuffle) (funExt (isoEq refl))) ⟩
+      (shuffle~ ∘ ℂ.idToIso A B ∘ idToIso* ∘ shuffle) x
+        ≡⟨ cong (λ φ → φ x)
+          (cong (λ φ → shuffle~ ∘ φ ∘ shuffle) recto-verso) ⟩
+      (shuffle~ ∘ shuffle) x
+        ≡⟨⟩
+      x ∎)
+    )
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category}. Proving univalence for the opposite category.}
+\end{figure}
+\clearpage
+\section{Products}
+\label{sec:app-products}
+\begin{figure}[h]
+\begin{Verbatim}
+module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
+  open Category ℂ
+
+  module _ (A B : Object) where
+    record RawProduct : Set (ℓa ⊔ ℓb) where
+      no-eta-equality
+      field
+        object : Object
+        fst  : ℂ [ object , A ]
+        snd  : ℂ [ object , B ]
+
+    record IsProduct (raw : RawProduct) : Set (ℓa ⊔ ℓb) where
+      open RawProduct raw public
+      field
+        ump : ∀ {X : Object} (f : ℂ [ X , A ]) (g : ℂ [ X , B ])
+          → ∃![ f×g ] (ℂ [ fst ∘ f×g ] ≡ f P.× ℂ [ snd ∘ f×g ] ≡ g)
+
+    record Product : Set (ℓa ⊔ ℓb) where
+      field
+        raw        : RawProduct
+        isProduct  : IsProduct raw
+
+      open IsProduct isProduct public
+
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category.Product}. Definition of products.}
+\end{figure}
+%
+\begin{figure}[h]
+\begin{Verbatim}
+module _{ℓa ℓb : Level} {ℂ : Category ℓa ℓb}
+  (let module ℂ = Category ℂ) {A* B* : ℂ.Object} where
+
+  module _ where
+    raw : RawCategory _ _
+    raw = record
+      { Object = Σ[ X ∈ ℂ.Object ] ℂ.Arrow X A* × ℂ.Arrow X B*
+      ; Arrow = λ{ (A , a0 , a1) (B , b0 , b1)
+        → Σ[ f ∈ ℂ.Arrow A B ]
+            ℂ [ b0 ∘ f ] ≡ a0
+          × ℂ [ b1 ∘ f ] ≡ a1
+          }
+      ; identity = λ{ {X , f , g}
+          → ℂ.identity {X} , ℂ.rightIdentity , ℂ.rightIdentity
+        }
+      ; _<<<_ = λ { {_ , a0 , a1} {_ , b0 , b1} {_ , c0 , c1}
+        (f , f0 , f1) (g , g0 , g1)
+        → (f ℂ.<<< g)
+          , (begin
+              ℂ [ c0 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
+              ℂ [ ℂ [ c0 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f0 ⟩
+              ℂ [ b0 ∘ g ] ≡⟨ g0 ⟩
+              a0 ∎
+            )
+          , (begin
+             ℂ [ c1 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
+             ℂ [ ℂ [ c1 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f1 ⟩
+             ℂ [ b1 ∘ g ] ≡⟨ g1 ⟩
+              a1 ∎
+            )
+        }
+      }
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category.Product}. Definition of ``pair category''.}
+\end{figure}
+\clearpage
+\section{Monads}
+\label{sec:app-monads}
+\begin{figure}[h]
+\begin{Verbatim}
+module Cat.Category.Monad.Kleisli
+  {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
+
+record RawMonad : Set ℓ where
+  field
+    omap : Object → Object
+    pure : {X : Object}   → ℂ [ X , omap X ]
+    bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ]
+
+  fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ omap A , omap B ]
+  fmap f = bind (pure <<< f)
+
+  _>=>_ : {A B C : Object}
+    → ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ]
+  f >=> g = f >>> (bind g)
+
+  join : {A : Object} → ℂ [ omap (omap A) , omap A ]
+  join = bind identity
+
+  IsIdentity     = {X : Object}
+    → bind pure ≡ identity {omap X}
+  IsNatural      = {X Y : Object}   (f : ℂ [ X , omap Y ])
+    → pure >=> f ≡ f
+  IsDistributive = {X Y Z : Object}
+      (g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ])
+    → (bind f) >>> (bind g) ≡ bind (f >=> g)
+
+record IsMonad (raw : RawMonad) : Set ℓ where
+  open RawMonad raw public
+  field
+    isIdentity     : IsIdentity
+    isNatural      : IsNatural
+    isDistributive : IsDistributive
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category.Monad.Kleisli}. Definition of
+  Kleisli monads.}
+\end{figure}
+%
+\begin{figure}[h]
+\begin{Verbatim}
+module Cat.Category.Monad.Monoidal
+  {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
+
+private
+  ℓ = ℓa ⊔ ℓb
+
+open Category ℂ using (Object ; Arrow ; identity ; _<<<_)
+
+record RawMonad : Set ℓ where
+  field
+    R      : EndoFunctor ℂ
+    pureNT : NaturalTransformation Functors.identity R
+    joinNT : NaturalTransformation F[ R ∘ R ] R
+
+  Romap = Functor.omap R
+  fmap = Functor.fmap R
+
+  pureT : Transformation Functors.identity R
+  pureT = fst pureNT
+
+  pure : {X : Object} → ℂ [ X , Romap X ]
+  pure = pureT _
+
+  pureN : Natural Functors.identity R pureT
+  pureN = snd pureNT
+
+  joinT : Transformation F[ R ∘ R ] R
+  joinT = fst joinNT
+  join : {X : Object} → ℂ [ Romap (Romap X) , Romap X ]
+  join = joinT _
+  joinN : Natural F[ R ∘ R ] R joinT
+  joinN = snd joinNT
+
+  bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ]
+  bind {X} {Y} f = join <<< fmap f
+
+  IsAssociative : Set _
+  IsAssociative = {X : Object}
+    → joinT X <<< fmap join ≡ join <<< join
+  IsInverse : Set _
+  IsInverse = {X : Object}
+    → join <<< pure      ≡ identity {Romap X}
+    × join <<< fmap pure ≡ identity {Romap X}
+
+record IsMonad (raw : RawMonad) : Set ℓ where
+  open RawMonad raw public
+  field
+    isAssociative : IsAssociative
+    isInverse     : IsInverse
+\end{Verbatim}
+\caption{Excerpt from module \texttt{Cat.Category.Monad.Monoidal}. Definition of
+  Monoidal monads.}
+\end{figure}

doc/title.tex

@@ -0,0 +1,95 @@
+%% FRONTMATTER
+\frontmatter
+%% \newgeometry{top=3cm, bottom=3cm,left=2.25 cm, right=2.25cm}
+\begingroup
+\thispagestyle{empty}
+{\Huge\thetitle}\\[.5cm]
+{\Large A formalization of category theory in Cubical Agda}\\[6cm]
+\begin{center}
+\includegraphics[width=\linewidth,keepaspectratio]{isomorphism.png}
+\end{center}
+% Cover text
+\vfill
+%% \renewcommand{\familydefault}{\sfdefault} \normalfont % Set cover page font
+{\Large\theauthor}\\[.5cm]
+Master's thesis in Computer Science
+\endgroup
+%% \end{titlepage}
+
+
+% BACK OF COVER PAGE (BLANK PAGE)
+\newpage
+%% \newgeometry{a4paper}	% Temporarily change margins
+%% \restoregeometry
+\thispagestyle{empty}
+\null
+
+%% \begin{titlepage}
+
+% TITLE PAGE
+\newpage
+\thispagestyle{empty}
+\begin{center}
+	\textsc{\LARGE Master's thesis \the\year}\\[4cm]		% Report number is currently not in use
+	\textbf{\LARGE \thetitle} \\[1cm]
+	{\large \subtitle}\\[1cm]
+	{\large \theauthor}
+	
+	\vfill	
+	\centering
+	\includegraphics[width=0.2\pdfpagewidth]{assets/logo_eng.pdf}
+  \vspace{5mm}
+	
+	\textsc{Department of Computer Science and Engineering}\\
+	\textsc{{\researchgroup}}\\
+	%Name of research group (if applicable)\\
+	\textsc{\institution} \\
+	\textsc{Gothenburg, Sweden \the\year}\\
+\end{center}
+
+
+% IMPRINT PAGE (BACK OF TITLE PAGE)
+\newpage
+\thispagestyle{plain}
+\textit{\thetitle}\\
+\subtitle\\
+\copyright\ \the\year ~ \textsc{\theauthor}
+\vspace{4.5cm}
+
+\setlength{\parskip}{0.5cm}
+\textbf{Author:}\\
+\theauthor\\
+\href{mailto:\authoremail>}{\texttt{<\authoremail>}}
+
+\textbf{Supervisor:}\\
+\supervisor\\
+\href{mailto:\supervisoremail>}{\texttt{<\supervisoremail>}}\\
+\supervisordepartment
+
+\textbf{Co-supervisor:}\\
+\cosupervisor\\
+\href{mailto:\cosupervisoremail>}{\texttt{<\cosupervisoremail>}}\\
+\cosupervisordepartment
+
+\textbf{Examiner:}\\
+\examiner\\
+\href{mailto:\examineremail>}{\texttt{<\examineremail>}}\\
+\examinerdepartment
+
+\vfill
+Master's Thesis \the\year\\	% Report number currently not in use
+\department\\
+%Division of Division name\\
+%Name of research group (if applicable)\\
+\institution\\
+SE-412 96 Gothenburg\\
+Telephone +46 31 772 1000 \setlength{\parskip}{0.5cm}\\
+% Caption for cover page figure if used, possibly with reference to further information in the report
+%% Cover: Wind visualization constructed in Matlab showing a surface of constant wind speed along with streamlines of the flow. \setlength{\parskip}{0.5cm}
+%Printed by [Name of printing company]\\
+Gothenburg, Sweden \the\year
+
+%% \restoregeometry
+%% \end{titlepage}
+
+\tableofcontents

libs/agda-stdlib

@@ -1 +1 @@
-Subproject commit 2033814d1f118401a37484390fdb5b75b83e6bb4
+Subproject commit ac331fc38ca05f85dfebc57eb1259ba2ea0e50d5

libs/cubical

@@ -1 +1 @@
-Subproject commit 19990b03b95f76210362a6e55b94181a5481f158
+Subproject commit b112c292ded61b02fa32a1b65cac77314a1e9698

proposal/chalmerstitle.sty

@@ -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}
-}

proposal/macros.tex

@@ -1,19 +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{\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}}

proposal/proposal.tex

@@ -1,282 +0,0 @@
-\documentclass{article}
-
-
-
-\usepackage[utf8]{inputenc}
-
-\usepackage{natbib}
-\usepackage[hidelinks]{hyperref}
-
-\usepackage{graphicx}
-
-\usepackage{parskip}
-\usepackage{multicol}
-\usepackage{amsmath,amssymb}
-% \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}
-\end{document}

report/.gitignore

@@ -1 +0,0 @@
-cat.pdf

report/Makefile

@@ -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)

report/cat.md

@@ -1,90 +0,0 @@
----
-title: Formalizing category theory in Agda - Project description
-date: May 27th 2017
-author: Frederik Hanghøj Iversen `<hanghj@student.chalmers.se>`
-bibliography: refs.bib
----
-
-Background
-==========
-
-Functional extensionality gives rise to a notion of equality of functions not
-present in intensional dependent type theory. A type-system called cubical
-type-theory is outlined in [@cohen-2016] that recovers the computational
-interprtation of the univalence theorem.
-
-Keywords: The category of sets, limits, colimits, functors, natural
-transformations, kleisly category, yoneda lemma, closed cartesian categories,
-propositional logic.
-
-<!--
-"[...] These foundations promise to resolve several seemingly unconnected
-problems-provide a support for categorical and higher categorical arguments
-directly on the level of the language, make formalizations of usual mathematics
-much more concise and much better adapted to the use with existing proof
-assistants such as Coq [...]"
-
-From "Univalent Foundations of Mathematics" by "Voevodsky".
-
--->
-
-Aim
-===
-
-The aim of the project is two-fold. The first part of the project will be
-concerned with formalizing some concepts from category theory in Agda's
-type-system. This formalization should aim to incorporate definitions and
-theorems that allow us to express the correpondence in the second part: Namely
-showing the correpondence between well-typed terms in cubical type theory as
-presented in Huber and Thierry's paper and with that of some concepts from Category Theory.
-
-This latter part is not entirely clear for me yet, I know that all these are relevant keywords:
-
-  * The category, C, of names and substitutions
-  * Cubical Sets, i.e.: Functors from C to Set (the category of sets)
-  * Presheaves
-  * Fibers and fibrations
-
-These are all formulated in the language of Category Theory. The purpose it to
-show what they correspond to in the in Cubical Type Theory. As I understand it
-at least the last buzzword on this list corresponds to Type Families.
-
-I'm not sure how I'll go about expressing this in Agda. I suspect it might
-be a matter of demostrating that these two formulations are isomorphic.
-
-So far I have some experience with at least expressing some categorical
-concepts in Agda using this new notion of equality. That is, equaility is in
-some sense a continuuous path from a point of some type to another. So at the
-moment, my understanding of cubical type theory is just that it has another
-notion of equality but is otherwise pretty much the same.
-
-Timeplan
-========
-
-The first part of the project will focus on studying and understanding the
-foundations for this project namely; familiarizing myself with basic concepts
-from category theory, understanding how cubical type theory gives rise to
-expressing functional extensionality and the univalence theorem.
-
-After I have understood these fundamental concepts I will use them in the
-formalization of functors, applicative functors, monads, etc.. in Agda. This
-should be done before the end of the first semester of the school-year
-2017/2018.
-
-At this point I will also have settled on a direction for the rest of the
-project and developed a time-plan for the second phase of the project. But
-cerainly it will involve applying the result of phase 1 in some context as
-mentioned in [the project aim][aim].
-
-Resources
-=========
-
-* Cubical demo by Andrea Vezossi: [@cubical-demo]
-* Paper on cubical type theory [@cohen-2016]
-* Book on homotopy type theory: [@hott-2013]
-* Book on category theory: [@awodey-2006]
-* Modal logic - Modal type theory,
-  see [ncatlab](https://ncatlab.org/nlab/show/modal+type+theory).
-
-References
-==========

report/refs.bib

@@ -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}
-}

src/Cat.agda

@@ -0,0 +1,24 @@
+module Cat where
+
+open import Cat.Category
+
+open import Cat.Category.Functor
+open import Cat.Category.Product
+open import Cat.Category.Exponential
+open import Cat.Category.CartesianClosed
+open import Cat.Category.NaturalTransformation
+open import Cat.Category.Yoneda
+open import Cat.Category.Monoid
+open import Cat.Category.Monad
+open import Cat.Category.Monad.Monoidal
+open import Cat.Category.Monad.Kleisli
+open import Cat.Category.Monad.Voevodsky
+
+open import Cat.Categories.Opposite
+open import Cat.Categories.Sets
+open import Cat.Categories.Cat
+open import Cat.Categories.Rel
+open import Cat.Categories.Free
+open import Cat.Categories.Fun
+-- open import Cat.Categories.Cube
+open import Cat.Categories.CwF

src/Cat/Categories/Cat.agda

@@ -1,55 +1,323 @@
-{-# OPTIONS --cubical #-}
+-- There is no category of categories in our interpretation
+{-# OPTIONS --cubical --allow-unsolved-metas #-}
 
-module Category.Categories.Cat where
+module Cat.Categories.Cat where
 
-open import Agda.Primitive
-open import Cubical
-open import Function
-open import Data.Product renaming (proj₁ to fst ; proj₂ to snd)
+open import Cat.Prelude renaming (fst to fst ; snd to snd)
 
-open import Category
+open import Cat.Category
+open import Cat.Category.Functor
+open import Cat.Category.Product
+open import Cat.Category.Exponential hiding (_×_ ; product)
+import Cat.Category.NaturalTransformation
+open import Cat.Categories.Fun
 
 -- The category of categories
-module _ {ℓ ℓ' : Level} where
+module _ (ℓ ℓ' : Level) where
+  RawCat : RawCategory (lsuc (ℓ ⊔ ℓ')) (ℓ ⊔ ℓ')
+  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
+  -- categories. There does, however, exist a 2-category of 1-categories.
+  --
+  -- Because of this there is no category of categories.
+  Cat : (unprovable : IsCategory RawCat) → Category (lsuc (ℓ ⊔ ℓ')) (ℓ ⊔ ℓ')
+  Category.raw        (Cat _)          = RawCat
+  Category.isCategory (Cat unprovable) = unprovable
+
+-- | In the following we will pretend there is a category of categories when
+-- e.g. talking about it being cartesian closed. It still makes sense to
+-- construct these things even though that category does not exist.
+--
+-- If the notion of a category is later generalized to work on different
+-- homotopy levels, then the proof that the category of categories is cartesian
+-- closed will follow immediately from these constructions.
+
+-- | the category of categories have products.
+module CatProduct {ℓ ℓ' : Level} (ℂ 𝔻 : Category ℓ ℓ') where
   private
-    _⊛_ = functor-comp
-    module _ {A B C D : Category {ℓ} {ℓ'}} {f : Functor A B} {g : Functor B C} {h : Functor C D} where
-      assc : h ⊛ (g ⊛ f) ≡ (h ⊛ g) ⊛ f
-      assc = {!!}
+    module ℂ = Category ℂ
+    module 𝔻 = Category 𝔻
 
-    module _ {A B : Category {ℓ} {ℓ'}} where
-      lift-eq : (f g : Functor A B)
-        → (eq* : Functor.func* f ≡ Functor.func* g)
-        -- TODO: Must transport here using the equality from above.
-        -- Reason:
-        --   func→  : Arrow A dom cod → Arrow B (func* dom) (func* cod)
-        --   func→₁ : Arrow A dom cod → Arrow B (func*₁ dom) (func*₁ cod)
-        -- In other words, func→ and func→₁ does not have the same type.
-  --      → Functor.func→ f ≡ Functor.func→ g
-  --      → Functor.ident f ≡ Functor.ident g
-  --       → Functor.distrib f ≡ Functor.distrib g
-        → f ≡ g
-      lift-eq
-        (functor func* func→ idnt distrib)
-        (functor func*₁ func→₁ idnt₁ distrib₁)
-        eq-func* = {!!}
+    module _ where
+      private
+        Obj = ℂ.Object × 𝔻.Object
+        Arr  : Obj → Obj → Set ℓ'
+        Arr (c , d) (c' , d') = ℂ [ c , c' ] × 𝔻 [ d , d' ]
+        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 ]}
 
-    module _ {A B : Category {ℓ} {ℓ'}} {f : Functor A B} where
-      idHere = identity {ℓ} {ℓ'} {A}
-      lem : (Functor.func* f) ∘ (Functor.func* idHere) ≡ Functor.func* f
-      lem = refl
-      ident-r : f ⊛ identity ≡ f
-      ident-r = lift-eq (f ⊛ identity) f refl
-      ident-l : identity ⊛ f ≡ f
-      ident-l = {!!}
+      rawProduct : RawCategory ℓ ℓ'
+      RawCategory.Object   rawProduct = Obj
+      RawCategory.Arrow    rawProduct = Arr
+      RawCategory.identity rawProduct = identity
+      RawCategory._<<<_    rawProduct = _<<<_
 
-  CatCat : Category {lsuc (ℓ ⊔ ℓ')} {ℓ ⊔ ℓ'}
-  CatCat =
-    record
-      { Object = Category {ℓ} {ℓ'}
-      ; Arrow = Functor
-      ; 𝟙 = identity
-      ; _⊕_ = functor-comp
-      ; assoc = {!!}
-      ; ident = ident-r , ident-l
+    open RawCategory rawProduct
+
+    arrowsAreSets : ArrowsAreSets
+    arrowsAreSets = setSig {sA = ℂ.arrowsAreSets} {sB = λ x → 𝔻.arrowsAreSets}
+    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
+
+    isCategory : IsCategory rawProduct
+    IsCategory.isPreCategory isCategory = isPreCategory
+    IsCategory.univalent     isCategory = univalent
+
+  object : Category ℓ ℓ'
+  Category.raw object = rawProduct
+  Category.isCategory object = isCategory
+
+  fstF : Functor object ℂ
+  fstF = record
+    { raw = record
+      { omap = fst ; fmap = fst }
+    ; isFunctor = record
+      { isIdentity = refl ; isDistributive = refl }
+    }
+
+  sndF : Functor object 𝔻
+  sndF = record
+    { raw = record
+      { omap = snd ; fmap = snd }
+    ; isFunctor = record
+      { isIdentity = refl ; isDistributive = refl }
+    }
+
+  module _ {X : Category ℓ ℓ'} (x₁ : Functor X ℂ) (x₂ : Functor X 𝔻) where
+    private
+      x : Functor X object
+      x = record
+        { raw = record
+          { omap = λ x → x₁.omap x , x₂.omap x
+          ; fmap = λ x → x₁.fmap x , x₂.fmap x
+          }
+        ; isFunctor = record
+          { isIdentity     = Σ≡ x₁.isIdentity x₂.isIdentity
+          ; isDistributive = Σ≡ x₁.isDistributive x₂.isDistributive
+          }
+        }
+        where
+          open module x₁ = Functor x₁
+          open module x₂ = Functor x₂
+
+      isUniqL : F[ fstF ∘ x ] ≡ x₁
+      isUniqL = Functor≡ refl
+
+      isUniqR : F[ sndF ∘ x ] ≡ x₂
+      isUniqR = Functor≡ refl
+
+      isUniq : F[ fstF ∘ x ] ≡ x₁ × F[ sndF ∘ x ] ≡ x₂
+      isUniq = isUniqL , isUniqR
+
+    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
+    Catℓ = Cat ℓ ℓ' unprovable
+
+  module _ (ℂ 𝔻 : Category ℓ ℓ') where
+    private
+      module P = CatProduct ℂ 𝔻
+
+      rawProduct : RawProduct Catℓ ℂ 𝔻
+      RawProduct.object rawProduct = P.object
+      RawProduct.fst  rawProduct = P.fstF
+      RawProduct.snd  rawProduct = P.sndF
+
+      isProduct : IsProduct Catℓ _ _ rawProduct
+      IsProduct.ump isProduct = P.isProduct
+
+    product : Product Catℓ ℂ 𝔻
+    Product.raw       product = rawProduct
+    Product.isProduct product = isProduct
+
+  instance
+    hasProducts : HasProducts Catℓ
+    hasProducts = record { product = product }
+
+-- | 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 𝔻
+    Categoryℓ = Category ℓ ℓ
+    open Fun ℂ 𝔻 renaming (identity to idN)
+
+    omap : Functor ℂ 𝔻 × ℂ.Object → 𝔻.Object
+    omap (F , A) = Functor.omap F A
+
+  -- The exponential object
+  object : Categoryℓ
+  object = Fun
+
+  module _ {dom cod : Functor ℂ 𝔻 × ℂ.Object} where
+    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
+
+    fmap : (pobj : NaturalTransformation F G × ℂ [ A , B ])
+      → 𝔻 [ F.omap A , G.omap B ]
+    fmap ((θ , θNat) , f) = 𝔻 [ θ B ∘ F.fmap f ]
+    -- Alternatively:
+    --
+    --   fmap ((θ , θNat) , f) = 𝔻 [ G.fmap f ∘ θ A ]
+    --
+    -- Since they are equal by naturality of θ.
+
+  open CatProduct renaming (object to _⊗_) using ()
+
+  module _ {c : Functor ℂ 𝔻 × ℂ.Object} where
+    open Σ c renaming (fst to F ; snd to C)
+
+    ident : fmap {c} {c} (identityNT F , ℂ.identity {A = snd c}) ≡ 𝔻.identity
+    ident = begin
+      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 (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
+      module H = Functor H
+
+    module _
+      {θ×f : NaturalTransformation F G × ℂ [ A , B ]}
+      {η×g : NaturalTransformation G H × ℂ [ B , C ]} where
+      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 (fst to ηθ   ; snd to ηθNat)
+
+      isDistributive :
+          𝔻 [ 𝔻 [ η C ∘ θ C ] ∘ F.fmap ( ℂ [ g ∘ f ] ) ]
+        ≡ 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ θ B ∘ F.fmap f ] ]
+      isDistributive = begin
+        𝔻 [ (ηθ C) ∘ F.fmap (ℂ [ g ∘ f ]) ]
+          ≡⟨ ηθNat (ℂ [ g ∘ f ]) ⟩
+        𝔻 [ H.fmap (ℂ [ g ∘ f ]) ∘ (ηθ A) ]
+          ≡⟨ cong (λ φ → 𝔻 [ φ ∘ ηθ A ]) (H.isDistributive) ⟩
+        𝔻 [ 𝔻 [ H.fmap g ∘ H.fmap f ] ∘ (ηθ A) ]
+          ≡⟨ sym 𝔻.isAssociative ⟩
+        𝔻 [ H.fmap g ∘ 𝔻 [ H.fmap f ∘ ηθ A ] ]
+          ≡⟨ cong (λ φ → 𝔻 [ H.fmap g ∘ φ ]) 𝔻.isAssociative ⟩
+        𝔻 [ H.fmap g ∘ 𝔻 [ 𝔻 [ H.fmap f ∘ η A ] ∘ θ A ] ]
+          ≡⟨ cong (λ φ → 𝔻 [ H.fmap g ∘ φ ]) (cong (λ φ → 𝔻 [ φ ∘ θ A ]) (sym (ηNat f))) ⟩
+        𝔻 [ H.fmap g ∘ 𝔻 [ 𝔻 [ η B ∘ G.fmap f ] ∘ θ A ] ]
+          ≡⟨ cong (λ φ → 𝔻 [ H.fmap g ∘ φ ]) (sym 𝔻.isAssociative) ⟩
+        𝔻 [ H.fmap g ∘ 𝔻 [ η B ∘ 𝔻 [ G.fmap f ∘ θ A ] ] ]
+          ≡⟨ 𝔻.isAssociative ⟩
+        𝔻 [ 𝔻 [ H.fmap g ∘ η B ] ∘ 𝔻 [ G.fmap f ∘ θ A ] ]
+          ≡⟨ cong (λ φ → 𝔻 [ φ ∘ 𝔻 [ G.fmap f ∘ θ A ] ]) (sym (ηNat g)) ⟩
+        𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ G.fmap f ∘ θ A ] ]
+          ≡⟨ cong (λ φ → 𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ φ ]) (sym (θNat f)) ⟩
+        𝔻 [ 𝔻 [ η C ∘ G.fmap g ] ∘ 𝔻 [ θ B ∘ F.fmap f ] ] ∎
+
+  eval : Functor (CatProduct.object object ℂ) 𝔻
+  eval = record
+    { raw = record
+      { omap = omap
+      ; fmap = λ {dom} {cod} → fmap {dom} {cod}
       }
+    ; isFunctor = record
+      { isIdentity = λ {o} → ident {o}
+      ; isDistributive = λ {f u n k y} → isDistributive {f} {u} {n} {k} {y}
+      }
+    }
+
+  module _ (𝔸 : Category ℓ ℓ) (F : Functor (𝔸 ⊗ ℂ) 𝔻) where
+    postulate
+      parallelProduct
+        : Functor 𝔸 object → Functor ℂ ℂ
+        → Functor (𝔸 ⊗ ℂ) (object ⊗ ℂ)
+      transpose : Functor 𝔸 object
+      eq : F[ eval ∘ (parallelProduct transpose (Functors.identity {ℂ = ℂ})) ] ≡ F
+      -- eq : F[ :eval: ∘ {!!} ] ≡ F
+      -- eq : Catℓ [ :eval: ∘ (HasProducts._|×|_ hasProducts transpose (identity Catℓ {o = ℂ})) ] ≡ F
+      -- eq' : (Catℓ [ :eval: ∘
+      --   (record { product = product } HasProducts.|×| transpose)
+      --   (identity Catℓ)
+      --   ])
+      --   ≡ F
+
+    -- For some reason after `e8215b2c051062c6301abc9b3f6ec67106259758`
+    -- `catTranspose` makes Agda hang. catTranspose : ∃![ F~ ] (Catℓ [
+    -- :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
+-- behind an unprovable statement.
+module _ (ℓ : Level) (unprovable : IsCategory (RawCat ℓ ℓ)) where
+  private
+    Catℓ : Category (lsuc (ℓ ⊔ ℓ)) (ℓ ⊔ ℓ)
+    Catℓ = Cat ℓ ℓ unprovable
+
+    module _ (ℂ 𝔻 : Category ℓ ℓ) where
+      module CatExp = CatExponential ℂ 𝔻
+      _⊗_ = CatProduct.object
+
+      -- Filling the hole causes Agda to loop indefinitely.
+      eval : Functor (CatExp.object ⊗ ℂ) 𝔻
+      eval = {!CatExp.eval!}
+
+      isExponential : IsExponential Catℓ ℂ 𝔻 CatExp.object eval
+      isExponential = {!CatExp.isExponential!}
+
+      exponent : Exponential Catℓ ℂ 𝔻
+      exponent = record
+        { obj           = CatExp.object
+        ; eval          = {!eval!}
+        ; isExponential = {!isExponential!}
+        }
+
+  hasExponentials : HasExponentials Catℓ
+  hasExponentials = record { exponent = exponent }

src/Cat/Categories/Cube.agda

@@ -0,0 +1,76 @@
+{-# OPTIONS --allow-unsolved-metas #-}
+module Cat.Categories.Cube where
+
+open import Cat.Prelude
+open import Level
+open import Data.Bool hiding (T)
+open import Data.Sum hiding ([_,_])
+open import Data.Unit
+open import Data.Empty
+open import Relation.Nullary
+open import Relation.Nullary.Decidable
+
+open import Cat.Category
+open import Cat.Category.Functor
+
+-- See chapter 1 for a discussion on how presheaf categories are CwF's.
+
+-- See section 6.8 in Huber's thesis for details on how to implement the
+-- categorical version of CTT
+
+open Category hiding (_<<<_)
+open Functor
+
+module _ {ℓ ℓ' : Level} (Ns : Set ℓ) where
+  private
+    -- Ns is the "namespace"
+    ℓo = (suc zero ⊔ ℓ)
+
+    FiniteDecidableSubset : Set ℓ
+    FiniteDecidableSubset = Ns → Dec ⊤
+
+    isTrue : Bool → Set
+    isTrue false = ⊥
+    isTrue true = ⊤
+
+    elmsof : FiniteDecidableSubset → Set ℓ
+    elmsof P = Σ Ns (λ σ → True (P σ)) -- (σ : Ns) → isTrue (P σ)
+
+    𝟚 : Set
+    𝟚 = Bool
+
+    module _ (I J : FiniteDecidableSubset) where
+      Hom' : Set ℓ
+      Hom' = elmsof I → elmsof J ⊎ 𝟚
+      isInl : {ℓa ℓb : Level} {A : Set ℓa} {B : Set ℓb} → A ⊎ B → Set
+      isInl (inj₁ _) = ⊤
+      isInl (inj₂ _) = ⊥
+
+      Def : Set ℓ
+      Def = (f : Hom') → Σ (elmsof I) (λ i → isInl (f i))
+
+      rules : Hom' → Set ℓ
+      rules f = (i j : elmsof I)
+        → case (f i) of λ
+          { (inj₁ (fi , _)) → case (f j) of λ
+            { (inj₁ (fj , _)) → fi ≡ fj → i ≡ j
+            ; (inj₂ _) → Lift _ ⊤
+            }
+          ; (inj₂ _) → Lift _ ⊤
+          }
+
+      Hom = Σ Hom' rules
+
+    module Raw = RawCategory
+    -- The category of names and substitutions
+    Rawℂ : RawCategory ℓ ℓ -- ℓo (lsuc lzero ⊔ ℓo)
+    Raw.Object Rawℂ = FiniteDecidableSubset
+    Raw.Arrow Rawℂ = Hom
+    Raw.identity Rawℂ {o} = inj₁ , λ { (i , ii) (j , jj) eq → Σ≡ eq {!refl!} }
+    Raw._<<<_ Rawℂ = {!!}
+
+    postulate IsCategoryℂ : IsCategory Rawℂ
+
+    ℂ : Category ℓ ℓ
+    raw ℂ = Rawℂ
+    isCategory ℂ = IsCategoryℂ

src/Cat/Categories/CwF.agda

@@ -0,0 +1,55 @@
+module Cat.Categories.CwF where
+
+open import Cat.Prelude
+
+open import Cat.Category
+open import Cat.Category.Functor
+open import Cat.Categories.Fam
+open import Cat.Categories.Opposite
+
+module _ {ℓa ℓb : Level} where
+  record CwF : Set (lsuc (ℓa ⊔ ℓb)) where
+    -- "A category with families consists of"
+    field
+      -- "A base category"
+      ℂ : Category ℓa ℓb
+    module ℂ = Category ℂ
+    -- It's objects are called contexts
+    Contexts = ℂ.Object
+    -- It's arrows are called substitutions
+    Substitutions = ℂ.Arrow
+    field
+      -- A functor T
+      T : Functor (opposite ℂ) (Fam ℓa ℓb)
+      -- Empty context
+      [] : ℂ.Terminal
+    private
+      module T = Functor T
+    Type : (Γ : ℂ.Object) → Set ℓa
+    Type Γ = fst (fst (T.omap Γ))
+
+    module _ {Γ : ℂ.Object} {A : Type Γ} where
+
+      -- module _ {A B : Object ℂ} {γ : ℂ [ A , B ]} where
+      --   k : Σ (fst (omap T B) → fst (omap T A))
+      --     (λ f →
+      --     {x : fst (omap T B)} →
+      --     snd (omap T B) x → snd (omap T A) (f x))
+      --   k = T.fmap γ
+      --   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
+          Γ&A : ℂ.Object
+          proj1 : ℂ [ Γ&A , Γ ]
+          -- proj2 : ????
+
+        -- if γ : ℂ [ A , B ]
+        -- then T .fmap γ (written T[γ]) interpret substitutions in types and terms respectively.
+        -- field
+        --   ump : {Δ : ℂ .Object} → (γ : ℂ [ Δ , Γ ])
+        --     → (a : {!!}) → {!!}

src/Cat/Categories/Fam.agda

@@ -0,0 +1,61 @@
+{-# OPTIONS --allow-unsolved-metas #-}
+module Cat.Categories.Fam where
+
+open import Cat.Prelude
+
+open import Cat.Category
+
+module _ (ℓa ℓb : Level) where
+  private
+    Object = Σ[ hA ∈ hSet ℓa ] (fst hA → hSet ℓb)
+    Arr : Object → Object → Set (ℓa ⊔ ℓb)
+    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
+      ; identity = λ { {A} → identity {A = A}}
+      ; _<<<_ = λ {a b c} → _<<<_ {a} {b} {c}
+      }
+
+    open RawCategory RawFam hiding (Object ; identity)
+
+    isAssociative : IsAssociative
+    isAssociative = Σ≡ refl refl
+
+    isIdentity : IsIdentity λ { {A} → identity {A} }
+    isIdentity = (Σ≡ refl refl) , Σ≡ refl refl
+
+    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

src/Cat/Categories/Free.agda

@@ -0,0 +1,81 @@
+{-# OPTIONS --allow-unsolved-metas --cubical #-}
+module Cat.Categories.Free where
+
+open import Cat.Prelude hiding (Path ; empty)
+
+open import Relation.Binary
+
+open import Cat.Category
+
+module _ {ℓ : Level} {A : Set ℓ} {ℓr : Level} where
+  data Path (R : Rel A ℓr) : (a b : A) → Set (ℓ ⊔ ℓr) where
+    empty : {a : A}                          → Path R a a
+    cons  : {a b c : A} → R b c → Path R a b → Path R a c
+
+  module _ {R : Rel A ℓr} where
+    concatenate : {a b c : A} → Path R b c → Path R a b → Path R a c
+    concatenate empty p = p
+    concatenate (cons x q) p = cons x (concatenate q p)
+    _++_ : {a b c : A} → Path R b c → Path R a b → Path R a c
+    a ++ b = concatenate a b
+
+    singleton : {a b : A} → R a b → Path R a b
+    singleton f = cons f empty
+
+module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
+  private
+    module ℂ = Category ℂ
+
+    RawFree : RawCategory ℓa (ℓa ⊔ ℓb)
+    RawCategory.Object   RawFree = ℂ.Object
+    RawCategory.Arrow    RawFree = Path ℂ.Arrow
+    RawCategory.identity RawFree = empty
+    RawCategory._<<<_    RawFree = concatenate
+
+    open RawCategory RawFree
+
+    isAssociative : {A B C D : ℂ.Object} {r : Path ℂ.Arrow A B} {q : Path ℂ.Arrow B C} {p : Path ℂ.Arrow C D}
+      → p ++ (q ++ r) ≡ (p ++ q) ++ r
+    isAssociative {r = r} {q} {empty} = refl
+    isAssociative {A} {B} {C} {D} {r = r} {q} {cons x p} = begin
+      cons x p ++ (q ++ r)   ≡⟨ cong (cons x) lem ⟩
+      cons x ((p ++ q) ++ r) ≡⟨⟩
+      (cons x p ++ q) ++ r ∎
+      where
+      lem : p ++ (q ++ r) ≡ ((p ++ q) ++ r)
+      lem = isAssociative {r = r} {q} {p}
+
+    ident-r : ∀ {A} {B} {p : Path ℂ.Arrow A B} → concatenate p empty ≡ p
+    ident-r {p = empty} = refl
+    ident-r {p = cons x p} = cong (cons x) ident-r
+
+    ident-l : ∀ {A} {B} {p : Path ℂ.Arrow A B} → concatenate empty p ≡ p
+    ident-l = refl
+
+    isIdentity : IsIdentity identity
+    isIdentity = ident-l , ident-r
+
+    open Univalence isIdentity
+
+    module _ {A B : ℂ.Object} where
+      arrowsAreSets : isSet (Path ℂ.Arrow A B)
+      arrowsAreSets a b p q = {!!}
+
+    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.isPreCategory isCategory = isPreCategory
+    IsCategory.univalent     isCategory = univalent
+
+  Free : Category _ _
+  Free = record { raw = RawFree ; isCategory = isCategory }

src/Cat/Categories/Fun.agda

@@ -0,0 +1,219 @@
+{-# 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
+import Cat.Category.NaturalTransformation
+  as NaturalTransformation
+open import Cat.Categories.Opposite
+
+module Fun {ℓc ℓc' ℓd ℓd' : Level} (ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where
+  open NaturalTransformation ℂ 𝔻 public hiding (module Properties)
+  private
+    module ℂ = Category ℂ
+    module 𝔻 = Category 𝔻
+
+    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}
+
+    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 ∎
+
+    module _ {A B : Functor ℂ 𝔻} where
+      module A = Functor A
+      module B = Functor B
+      module _ (iso : A ≊ B) where
+        omapEq : A.omap ≡ B.omap
+        omapEq = funExt eq
+          where
+          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
+
+
+        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
+      --     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
+
+      --   fmapEq : PathP (λ i → U (omapEq i)) A.fmap B.fmap
+      --   fmapEq = pathJ D d B.omap omapEq B.fmap B.isFunctor iso
+
+      --   rawEq : A.raw ≡ B.raw
+      --   rawEq i = record { omap = omapEq i ; fmap = fmapEq i }
+
+      -- private
+      --   f : (A ≡ B) → (A ≊ B)
+      --   f p = idToNatTrans p , idToNatTrans (sym p) , NaturalTransformation≡ A A (funExt (λ C → {!!})) , {!!}
+      --   g : (A ≊ B) → (A ≡ B)
+      --   g = Functor≡ ∘ rawEq
+      --   inv : AreInverses f g
+      --   inv = {!funExt λ p → ?!} , {!!}
+      postulate
+        iso : (A ≡ B) ≅ (A ≊ B)
+--      iso = f , g , inv
+
+      univ : (A ≡ B) ≃ (A ≊ B)
+      univ = fromIsomorphism _ _ iso
+
+    -- There used to be some work-in-progress on this theorem, please go back to
+    -- this point in time to see it:
+    --
+    -- commit 6b7d66b7fc936fe3674b2fd9fa790bd0e3fec12f
+    -- Author: Frederik Hanghøj Iversen <fhi.1990@gmail.com>
+    -- Date:   Fri Apr 13 15:26:46 2018 +0200
+    univalent : Univalent
+    univalent = univalenceFrom≃ univ
+
+    isCategory : IsCategory raw
+    IsCategory.isPreCategory isCategory = isPreCategory
+    IsCategory.univalent     isCategory = univalent
+
+  Fun : Category (ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd') (ℓc ⊔ ℓc' ⊔ ℓd')
+  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.
+    raw : RawCategory (ℓ ⊔ lsuc ℓ') (ℓ ⊔ ℓ')
+    raw = record
+      { Object = Presheaf ℂ
+      ; Arrow = NaturalTransformation
+      ; identity = λ {F} → identity F
+      ; _<<<_ = λ {F G H} → NT[_∘_] {F = F} {G = G} {H = H}
+      }
+
+  --   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

src/Cat/Categories/Opposite.agda

@@ -0,0 +1,96 @@
+{-# OPTIONS --cubical #-}
+module Cat.Categories.Opposite where
+
+open import Cat.Prelude
+open import Cat.Equivalence
+open import Cat.Category
+
+-- | The opposite category
+--
+-- The opposite category is the category where the direction of the arrows are
+-- flipped.
+module _ {ℓa ℓb : Level} where
+  module _ (ℂ : Category ℓa ℓb) where
+    private
+      module _ where
+        module ℂ = Category ℂ
+        opRaw : RawCategory ℓa ℓb
+        RawCategory.Object   opRaw = ℂ.Object
+        RawCategory.Arrow    opRaw = flip ℂ.Arrow
+        RawCategory.identity opRaw = ℂ.identity
+        RawCategory._<<<_    opRaw = ℂ._>>>_
+
+        open RawCategory opRaw
+
+        isPreCategory : IsPreCategory opRaw
+        IsPreCategory.isAssociative isPreCategory = sym ℂ.isAssociative
+        IsPreCategory.isIdentity    isPreCategory = swap ℂ.isIdentity
+        IsPreCategory.arrowsAreSets isPreCategory = ℂ.arrowsAreSets
+
+      open IsPreCategory isPreCategory
+
+      module _ {A B : ℂ.Object} where
+        open Σ (toIso _ _ (ℂ.univalent {A} {B}))
+          renaming (fst to idToIso* ; snd to inv*)
+        open AreInverses {f = ℂ.idToIso A B} {idToIso*} inv*
+
+        shuffle : A ≊ B → A ℂ.≊ B
+        shuffle (f , g , inv) = g , f , inv
+
+        shuffle~ : A ℂ.≊ B → A ≊ B
+        shuffle~ (f , g , inv) = g , f , inv
+
+        lem : (p : A ≡ B) → idToIso A B p ≡ shuffle~ (ℂ.idToIso A B p)
+        lem p = isoEq refl
+
+        isoToId* : A ≊ B → A ≡ B
+        isoToId* = idToIso* ∘ shuffle
+
+        inv : AreInverses (idToIso A B) isoToId*
+        inv =
+          ( funExt (λ x → begin
+            (isoToId* ∘ idToIso A B) x
+              ≡⟨⟩
+            (idToIso*  ∘ shuffle ∘ idToIso A B) x
+              ≡⟨ cong (λ φ → φ x) (cong (λ φ → idToIso* ∘ shuffle ∘ φ) (funExt lem)) ⟩
+            (idToIso*  ∘ shuffle ∘ shuffle~ ∘ ℂ.idToIso A B) x
+              ≡⟨⟩
+            (idToIso*  ∘ ℂ.idToIso A B) x
+              ≡⟨ (λ i → verso-recto i x) ⟩
+            x ∎)
+          , funExt (λ x → begin
+            (idToIso A B ∘ idToIso* ∘ shuffle) x
+              ≡⟨ cong (λ φ → φ x) (cong (λ φ → φ ∘ idToIso* ∘ shuffle) (funExt lem)) ⟩
+            (shuffle~ ∘ ℂ.idToIso A B ∘ idToIso* ∘ shuffle) x
+              ≡⟨ cong (λ φ → φ x) (cong (λ φ → shuffle~ ∘ φ ∘ shuffle) recto-verso) ⟩
+            (shuffle~ ∘ shuffle) x
+              ≡⟨⟩
+            x ∎)
+          )
+
+      isCategory : IsCategory opRaw
+      IsCategory.isPreCategory isCategory = isPreCategory
+      IsCategory.univalent     isCategory
+        = univalenceFromIsomorphism (isoToId* , inv)
+
+    opposite : Category ℓa ℓb
+    Category.raw        opposite = opRaw
+    Category.isCategory opposite = isCategory
+
+  -- As demonstrated here a side-effect of having no-eta-equality on constructors
+  -- means that we need to pick things apart to show that things are indeed
+  -- definitionally equal. I.e; a thing that would normally be provable in one
+  -- line now takes 13!! Admittedly it's a simple proof.
+  module _ {ℂ : Category ℓa ℓb} where
+    open Category ℂ
+    private
+      -- Since they really are definitionally equal we just need to pick apart
+      -- the data-type.
+      rawInv : Category.raw (opposite (opposite ℂ)) ≡ raw
+      RawCategory.Object   (rawInv _) = Object
+      RawCategory.Arrow    (rawInv _) = Arrow
+      RawCategory.identity (rawInv _) = identity
+      RawCategory._<<<_    (rawInv _) = _<<<_
+
+    oppositeIsInvolution : opposite (opposite ℂ) ≡ ℂ
+    oppositeIsInvolution = Category≡ rawInv

src/Cat/Categories/Rel.agda

@@ -1,12 +1,8 @@
-{-# OPTIONS --cubical #-}
+{-# OPTIONS --cubical --allow-unsolved-metas #-}
 module Cat.Categories.Rel where
 
-open import Cubical.PathPrelude
-open import Cubical.GradLemma
-open import Agda.Primitive
-open import Data.Product renaming (proj₁ to fst ; proj₂ to snd)
-open import Function
-import Cubical.FromStdLib
+open import Cat.Prelude hiding (Rel)
+open import Cat.Equivalence
 
 open import Cat.Category
 
@@ -56,7 +52,6 @@ module _ {A B : Set} {S : Subset (A × B)} (ab : A × B) where
       backwards (a' , (a=a' , a'b∈S)) = subst (sym a=a') a'b∈S
 
       fwd-bwd : (x : (a , b) ∈ S) → (backwards ∘ forwards) x ≡ x
-      -- isbijective x = pathJ (λ y x₁ → (backwards ∘ forwards) x ≡ x) {!!} {!!} {!!}
       fwd-bwd x = pathJprop (λ y _ → y) x
 
       bwd-fwd : (x : Σ[ a' ∈ A ] (a , a') ∈ Diag A × (a' , b) ∈ S)
@@ -67,19 +62,13 @@ module _ {A B : Set} {S : Subset (A × B)} (ab : A × B) where
           lem0 = (λ a'' a≡a'' → ∀ a''b∈S → (forwards ∘ backwards) (a'' , a≡a'' , a''b∈S) ≡ (a'' , a≡a'' , a''b∈S))
           lem1 = (λ z₁ → cong (\ z → a , refl , z) (pathJprop (\ y _ → y) z₁))
 
-      isequiv : isEquiv
-        (Σ[ a' ∈ A ] (a , a') ∈ Diag A × (a' , b) ∈ S)
-        ((a , b) ∈ S)
-        backwards
-      isequiv y = gradLemma backwards forwards fwd-bwd bwd-fwd y
-
       equi : (Σ[ a' ∈ A ] (a , a') ∈ Diag A × (a' , b) ∈ S)
         ≃ (a , b) ∈ S
-      equi = backwards Cubical.FromStdLib., isequiv
+      equi = fromIsomorphism _ _ (backwards , forwards , funExt bwd-fwd , funExt fwd-bwd)
 
-    ident-l : (Σ[ a' ∈ A ] (a , a') ∈ Diag A × (a' , b) ∈ S)
+    ident-r : (Σ[ a' ∈ A ] (a , a') ∈ Diag A × (a' , b) ∈ S)
       ≡ (a , b) ∈ S
-    ident-l = equivToPath equi
+    ident-r = equivToPath equi
 
   module _ where
     private
@@ -101,19 +90,13 @@ module _ {A B : Set} {S : Subset (A × B)} (ab : A × B) where
           lem0 = (λ b'' b≡b'' → (ab''∈S : (a , b'') ∈ S) → (forwards ∘ backwards) (b'' , ab''∈S , sym b≡b'') ≡ (b'' , ab''∈S , sym b≡b''))
           lem1 = (λ ab''∈S → cong (λ φ → b , φ , refl) (pathJprop (λ y _ → y) ab''∈S))
 
-      isequiv : isEquiv
-        (Σ[ b' ∈ B ] (a , b') ∈ S × (b' , b) ∈ Diag B)
-        ((a , b) ∈ S)
-        backwards
-      isequiv ab∈S = gradLemma backwards forwards bwd-fwd fwd-bwd ab∈S
-
       equi : (Σ[ b' ∈ B ] (a , b') ∈ S × (b' , b) ∈ Diag B)
         ≃ ab ∈ S
-      equi = backwards Cubical.FromStdLib., isequiv
+      equi = fromIsomorphism _ _ (backwards , (forwards , funExt fwd-bwd , funExt bwd-fwd))
 
-    ident-r : (Σ[ b' ∈ B ] (a , b') ∈ S × (b' , b) ∈ Diag B)
+    ident-l : (Σ[ b' ∈ B ] (a , b') ∈ S × (b' , b) ∈ Diag B)
       ≡ ab ∈ S
-    ident-r = equivToPath equi
+    ident-l = equivToPath equi
 
 module _ {A B C D : Set} {S : Subset (A × B)} {R : Subset (B × C)} {Q : Subset (C × D)} (ad : A × D) where
   private
@@ -139,27 +122,28 @@ module _ {A B C D : Set} {S : Subset (A × B)} {R : Subset (B × C)} {Q : Subset
     bwd-fwd : (x : Q⊕⟨R⊕S⟩) → (bwd ∘ fwd) x ≡ x
     bwd-fwd x = refl
 
-    isequiv : isEquiv
-      (Σ[ c ∈ C ] (Σ[ b ∈ B ] (a , b) ∈ S × (b , c) ∈ R) × (c , d) ∈ Q)
-      (Σ[ b ∈ B ] (a , b) ∈ S × (Σ[ c ∈ C ] (b , c) ∈ R × (c , d) ∈ Q))
-      fwd
-    isequiv = gradLemma fwd bwd fwd-bwd bwd-fwd
-
     equi : (Σ[ c ∈ C ] (Σ[ b ∈ B ] (a , b) ∈ S × (b , c) ∈ R) × (c , d) ∈ Q)
       ≃ (Σ[ b ∈ B ] (a , b) ∈ S × (Σ[ c ∈ C ] (b , c) ∈ R × (c , d) ∈ Q))
-    equi = fwd Cubical.FromStdLib., isequiv
+    equi = fromIsomorphism _ _ (fwd , bwd , funExt bwd-fwd , funExt fwd-bwd)
 
-    -- assocc : Q + (R + S) ≡ (Q + R) + S
-  is-assoc : (Σ[ c ∈ C ] (Σ[ b ∈ B ] (a , b) ∈ S × (b , c) ∈ R) × (c , d) ∈ Q)
+    -- isAssociativec : Q + (R + S) ≡ (Q + R) + S
+  is-isAssociative : (Σ[ c ∈ C ] (Σ[ b ∈ B ] (a , b) ∈ S × (b , c) ∈ R) × (c , d) ∈ Q)
          ≡ (Σ[ b ∈ B ] (a , b) ∈ S × (Σ[ c ∈ C ] (b , c) ∈ R × (c , d) ∈ Q))
-  is-assoc = equivToPath equi
+  is-isAssociative = equivToPath equi
 
-Rel : Category
-Rel = record
+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 )}
-  ; assoc = funExt is-assoc
-  ; ident = funExt ident-l , funExt ident-r
+  ; identity = λ {S} → Diag S
+  ; _<<<_ = λ {A B C} S R → λ {( a , c ) → Σ[ b ∈ B ] ( (a , b) ∈ R × (b , c) ∈ S )}
   }
+
+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

src/Cat/Categories/Sets.agda

@@ -1,52 +1,155 @@
-{-# OPTIONS --allow-unsolved-metas #-}
-
+-- | The category of homotopy sets
+{-# OPTIONS --cubical --caching #-}
 module Cat.Categories.Sets where
 
-open import Cubical.PathPrelude
-open import Agda.Primitive
-open import Data.Product
-open import Data.Product renaming (proj₁ to fst ; proj₂ to snd)
-
+open import Cat.Prelude as P
+open import Cat.Equivalence
 open import Cat.Category
-open import Cat.Functor
+open import Cat.Category.Functor
+open import Cat.Category.Product
+open import Cat.Categories.Opposite
 
--- Sets are built-in to Agda. The set of all small sets is called Set.
+_⊙_ : {ℓ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
 
-Fun : {ℓ : Level} → ( T U : Set ℓ ) → Set ℓ
-Fun T U = T → U
+sym≃ : ∀ {ℓa ℓb} {A : Set ℓa} {B : Set ℓb} → A ≃ B → B ≃ A
+sym≃ = Equivalence.symmetry
 
-Sets : {ℓ : Level} → Category {lsuc ℓ} {ℓ}
-Sets {ℓ} = record
-  { Object = Set ℓ
-  ; Arrow = λ T U → Fun {ℓ} T U
-  ; 𝟙 = λ x → x
-  ; _⊕_  = λ g f x → g ( f x )
-  ; assoc = refl
-  ; ident = funExt (λ x → refl) , funExt (λ x → refl)
-  }
+infixl 10 _⊙_
 
-Representable : {ℓ ℓ' : Level} → (ℂ : Category {ℓ} {ℓ'}) → Set (ℓ ⊔ lsuc ℓ')
-Representable {ℓ' = ℓ'} ℂ = Functor ℂ (Sets {ℓ'})
+module _ (ℓ : Level) where
+  private
+    SetsRaw : RawCategory (lsuc ℓ) ℓ
+    RawCategory.Object   SetsRaw = hSet ℓ
+    RawCategory.Arrow    SetsRaw (T , _) (U , _) = T → U
+    RawCategory.identity SetsRaw = idFun _
+    RawCategory._<<<_    SetsRaw = _∘′_
 
-representable : {ℓ ℓ' : Level} → {ℂ : Category {ℓ} {ℓ'}} → Category.Object ℂ → Representable ℂ
-representable {ℂ = ℂ} A = record
-  { func* = λ B → ℂ.Arrow A B
-  ; func→ = λ f g → f ℂ.⊕ g
-  ; ident = funExt λ _ → snd ℂ.ident
-  ; distrib = funExt λ x → sym ℂ.assoc
-  }
-  where
-    open module ℂ = Category ℂ
+    module _ where
+      private
+        open RawCategory SetsRaw hiding (_<<<_)
 
-Presheaf : {ℓ ℓ' : Level} → (ℂ : Category {ℓ} {ℓ'}) → Set (ℓ ⊔ lsuc ℓ')
-Presheaf {ℓ' = ℓ'} ℂ = Functor (Opposite ℂ) (Sets {ℓ'})
+        isIdentity : IsIdentity (idFun _)
+        fst isIdentity = funExt λ _ → refl
+        snd isIdentity = funExt λ _ → refl
 
-presheaf : {ℓ ℓ' : Level} → {ℂ : Category {ℓ} {ℓ'}} → Category.Object (Opposite ℂ) → Presheaf ℂ
-presheaf {ℂ = ℂ} B = record
-  { func* = λ A → ℂ.Arrow A B
-  ; func→ = λ f g → g ℂ.⊕ f
-  ; ident = funExt λ x → fst ℂ.ident
-  ; distrib = funExt λ x → ℂ.assoc
-  }
-  where
-    open module ℂ = Category ℂ
+        arrowsAreSets : ArrowsAreSets
+        arrowsAreSets {B = (_ , s)} = setPi λ _ → s
+
+      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 (fst to A ; snd to sA)
+      open Σ hB renaming (fst to B ; snd to sB)
+
+      univ≃ : (hA ≡ hB) ≃ (hA ≊ hB)
+      univ≃
+        = equivSigProp (λ A → isSetIsProp)
+        ⊙ univalence
+        ⊙ equivSig {P = isEquiv A B} {Q = TypeIsomorphism} (equiv≃iso sA sB)
+
+    univalent : Univalent
+    univalent = univalenceFrom≃ univ≃
+
+    SetsIsCategory : IsCategory SetsRaw
+    IsCategory.isPreCategory SetsIsCategory = isPreCat
+    IsCategory.univalent     SetsIsCategory = univalent
+
+  𝓢𝓮𝓽 Sets : Category (lsuc ℓ) ℓ
+  Category.raw 𝓢𝓮𝓽 = SetsRaw
+  Category.isCategory 𝓢𝓮𝓽 = SetsIsCategory
+  Sets = 𝓢𝓮𝓽
+
+module _ {ℓ : Level} where
+  private
+    𝓢 = 𝓢𝓮𝓽 ℓ
+    open Category 𝓢
+
+    module _ (hA hB : Object) where
+      open Σ hA renaming (fst to A ; snd to sA)
+      open Σ hB renaming (fst to B ; snd to sB)
+
+      private
+        productObject : Object
+        productObject = (A × B) , sigPresSet sA λ _ → sB
+
+        module _ {X A B : Set ℓ} (f : X → A) (g : X → B) where
+          _&&&_ : (X → A × B)
+          _&&&_ x = f x , g x
+
+        module _ (hX : Object) where
+          open Σ hX renaming (fst to X)
+          module _ (f : X → A ) (g : X → B) where
+            ump : fst ∘′ (f &&& g) ≡ f × snd ∘′ (f &&& g) ≡ g
+            fst ump = refl
+            snd ump = refl
+
+        rawProduct : RawProduct 𝓢 hA hB
+        RawProduct.object rawProduct = productObject
+        RawProduct.fst    rawProduct = fst
+        RawProduct.snd    rawProduct = snd
+
+        isProduct : IsProduct 𝓢 _ _ rawProduct
+        IsProduct.ump isProduct {X = 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
+      Product.isProduct product = isProduct
+
+  instance
+    SetsHasProducts : HasProducts 𝓢
+    SetsHasProducts = record { product = product }
+
+module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
+  open Category ℂ
+
+  -- Covariant Presheaf
+  Representable : Set (ℓa ⊔ lsuc ℓb)
+  Representable = Functor ℂ (𝓢𝓮𝓽 ℓb)
+
+  -- Contravariant Presheaf
+  Presheaf : Set (ℓa ⊔ lsuc ℓb)
+  Presheaf = Functor (opposite ℂ) (𝓢𝓮𝓽 ℓb)
+
+  -- The "co-yoneda" embedding.
+  representable : Category.Object ℂ → Representable
+  representable A = record
+    { raw = record
+      { omap = λ B → ℂ [ A , B ] , arrowsAreSets
+      ; fmap = ℂ [_∘_]
+      }
+    ; isFunctor = record
+      { isIdentity     = funExt λ _ → leftIdentity
+      ; isDistributive = funExt λ x → sym isAssociative
+      }
+    }
+
+  -- Alternate name: `yoneda`
+  presheaf : Category.Object (opposite ℂ) → Presheaf
+  presheaf B = record
+    { raw = record
+      { omap = λ A → ℂ [ A , B ] , arrowsAreSets
+      ; fmap = λ f g → ℂ [ g ∘ f ]
+    }
+    ; isFunctor = record
+      { isIdentity     = funExt λ x → rightIdentity
+      ; isDistributive = funExt λ x → isAssociative
+      }
+    }

src/Cat/Categories/Span.agda

@@ -0,0 +1,170 @@
+{-# OPTIONS --cubical --caching #-}
+module Cat.Categories.Span where
+
+open import Cat.Prelude as P hiding (_×_ ; fst ; snd)
+open import Cat.Equivalence
+open import Cat.Category
+
+module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb)
+  (let module ℂ = Category ℂ) (𝒜 ℬ : ℂ.Object) where
+
+  open P
+
+  private
+    module _ where
+      raw : RawCategory _ _
+      raw = record
+        { Object = Σ[ X ∈ ℂ.Object ] ℂ.Arrow X 𝒜 × ℂ.Arrow X ℬ
+        ; Arrow = λ{ (A , a0 , a1) (B , b0 , b1)
+          → Σ[ f ∈ ℂ.Arrow A B ]
+              ℂ [ b0 ∘ f ] ≡ a0
+            × ℂ [ b1 ∘ f ] ≡ a1
+            }
+        ; identity = λ{ {X , f , g} → ℂ.identity {X} , ℂ.rightIdentity , ℂ.rightIdentity}
+        ; _<<<_ = λ { {_ , a0 , a1} {_ , b0 , b1} {_ , c0 , c1} (f , f0 , f1) (g , g0 , g1)
+          → (f ℂ.<<< g)
+            , (begin
+                ℂ [ c0 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
+                ℂ [ ℂ [ c0 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f0 ⟩
+                ℂ [ b0 ∘ g ] ≡⟨ g0 ⟩
+                a0 ∎
+              )
+            , (begin
+               ℂ [ c1 ∘ ℂ [ f ∘ g ] ] ≡⟨ ℂ.isAssociative ⟩
+               ℂ [ ℂ [ c1 ∘ f ] ∘ g ] ≡⟨ cong (λ φ → ℂ [ φ ∘ g ]) f1 ⟩
+               ℂ [ b1 ∘ g ] ≡⟨ g1 ⟩
+                a1 ∎
+              )
+          }
+        }
+
+      module _ where
+        open RawCategory raw
+
+        propEqs : ∀ {X' : Object}{Y' : Object} (let X , xa , xb = X') (let Y , ya , yb = Y')
+                    → (xy : ℂ.Arrow X Y) → isProp (ℂ [ ya ∘ xy ] ≡ xa × ℂ [ yb ∘ xy ] ≡ xb)
+        propEqs xs = propSig (ℂ.arrowsAreSets _ _) (\ _ → ℂ.arrowsAreSets _ _)
+
+        arrowEq : {X Y : Object} {f g : Arrow X Y} → fst f ≡ fst g → f ≡ g
+        arrowEq {X} {Y} {f} {g} p = λ i → p i , lemPropF propEqs p {snd f} {snd g} i
+
+        isAssociative : IsAssociative
+        isAssociative {f = f , f0 , f1} {g , g0 , g1} {h , h0 , h1} = arrowEq ℂ.isAssociative
+
+        isIdentity : IsIdentity identity
+        isIdentity {AA@(A , a0 , a1)} {BB@(B , b0 , b1)} {f , f0 , f1} = arrowEq ℂ.leftIdentity , arrowEq ℂ.rightIdentity
+
+        arrowsAreSets : ArrowsAreSets
+        arrowsAreSets {X , x0 , x1} {Y , y0 , y1}
+          = sigPresSet ℂ.arrowsAreSets λ a → propSet (propEqs _)
+
+        isPreCat : IsPreCategory raw
+        IsPreCategory.isAssociative isPreCat = isAssociative
+        IsPreCategory.isIdentity    isPreCat = isIdentity
+        IsPreCategory.arrowsAreSets isPreCat = arrowsAreSets
+
+      open IsPreCategory isPreCat
+
+      module _ {𝕏 𝕐 : Object} where
+        open Σ 𝕏 renaming (fst to X ; snd to x)
+        open Σ x renaming (fst to xa ; snd to xb)
+        open Σ 𝕐 renaming (fst to Y ; snd to y)
+        open Σ y renaming (fst to ya ; snd to yb)
+        open import Cat.Equivalence using (composeIso) renaming (_≅_ to _≅_)
+
+        -- The proof will be a sequence of isomorphisms between the
+        -- following 4 types:
+        T0 = ((X , xa , xb) ≡ (Y , ya , yb))
+        T1 = (Σ[ p ∈ (X ≡ Y) ] (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb))
+        T2 = Σ (X ℂ.≊ Y) (λ iso
+            → let p = ℂ.isoToId iso
+            in
+            ( PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya)
+            × PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb
+            )
+        T3 = ((X , xa , xb) ≊ (Y , ya , yb))
+
+        step0 : T0 ≅ T1
+        step0
+          = (λ p → cong fst p , cong-d (fst ∘ snd) p , cong-d (snd ∘ snd) p)
+          -- , (λ x  → λ i → fst x i , (fst (snd x) i) , (snd (snd x) i))
+          , (λ{ (p , q , r) → Σ≡ p λ i → q i , r i})
+          , funExt (λ{ p → refl})
+          , funExt (λ{ (p , q , r) → refl})
+
+        step1 : T1 ≅ T2
+        step1
+          = symIso
+              (isoSigFst
+                {A = (X ℂ.≊ Y)}
+                {B = (X ≡ Y)}
+                (ℂ.groupoidObject _ _)
+                {Q = \ p → (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa ya) × (PathP (λ i → ℂ.Arrow (p i) ℬ) xb yb)}
+                ℂ.isoToId
+                (symIso (_ , ℂ.asTypeIso {X} {Y}) .snd)
+              )
+
+        step2 : T2 ≅ T3
+        step2
+          = ( λ{ (iso@(f , f~ , inv-f) , p , q)
+              → ( f  , sym (ℂ.domain-twist-sym  iso p) , sym (ℂ.domain-twist-sym iso q))
+              , ( f~ , sym (ℂ.domain-twist      iso p) , sym (ℂ.domain-twist     iso q))
+              , arrowEq (fst inv-f)
+              , arrowEq (snd inv-f)
+              }
+            )
+          , (λ{ (f , f~ , inv-f , inv-f~) →
+            let
+              iso : X ℂ.≊ Y
+              iso = fst f , fst f~ , cong fst inv-f , cong fst inv-f~
+              p : X ≡ Y
+              p = ℂ.isoToId iso
+              pA : ℂ.Arrow X 𝒜 ≡ ℂ.Arrow Y 𝒜
+              pA = cong (λ x → ℂ.Arrow x 𝒜) p
+              pB : ℂ.Arrow X ℬ ≡ ℂ.Arrow Y ℬ
+              pB = cong (λ x → ℂ.Arrow x ℬ) p
+              k0 = begin
+                coe pB xb ≡⟨ ℂ.coe-dom iso ⟩
+                xb ℂ.<<< fst f~ ≡⟨ snd (snd f~) ⟩
+                yb ∎
+              k1 = begin
+                coe pA xa ≡⟨ ℂ.coe-dom iso ⟩
+                xa ℂ.<<< fst f~ ≡⟨ fst (snd f~) ⟩
+                ya ∎
+            in iso , coe-lem-inv k1 , coe-lem-inv k0})
+          , funExt (λ x → lemSig
+              (λ x → propSig prop0 (λ _ → prop1))
+              _ _
+              (Σ≡ refl (ℂ.propIsomorphism _ _ _)))
+          , funExt (λ{ (f , _) → lemSig propIsomorphism _ _ (Σ≡ refl (propEqs _ _ _))})
+            where
+            prop0 : ∀ {x} → isProp (PathP (λ i → ℂ.Arrow (ℂ.isoToId x i) 𝒜) xa ya)
+            prop0 {x} = pathJ (λ y p → ∀ x → isProp (PathP (λ i → ℂ.Arrow (p i) 𝒜) xa x)) (λ x → ℂ.arrowsAreSets _ _) Y (ℂ.isoToId x) ya
+            prop1 : ∀ {x} → isProp (PathP (λ i → ℂ.Arrow (ℂ.isoToId x i) ℬ) xb yb)
+            prop1 {x} = pathJ (λ y p → ∀ x → isProp (PathP (λ i → ℂ.Arrow (p i) ℬ) xb x)) (λ x → ℂ.arrowsAreSets _ _) Y (ℂ.isoToId x) yb
+        -- One thing to watch out for here is that the isomorphisms going forwards
+        -- must compose to give idToIso
+        iso
+          : ((X , xa , xb) ≡ (Y , ya , yb))
+          ≅ ((X , xa , xb) ≊ (Y , ya , yb))
+        iso = step0 ⊙ step1 ⊙ step2
+          where
+          infixl 5 _⊙_
+          _⊙_ = composeIso
+        equiv1
+          : ((X , xa , xb) ≡ (Y , ya , yb))
+          ≃ ((X , xa , xb) ≊ (Y , ya , yb))
+        equiv1 = _ , fromIso _ _ (snd iso)
+
+      univalent : Univalent
+      univalent = univalenceFrom≃ equiv1
+
+      isCat : IsCategory raw
+      IsCategory.isPreCategory isCat = isPreCat
+      IsCategory.univalent     isCat = univalent
+
+  span : Category _ _
+  span = record
+    { raw = raw
+    ; isCategory = isCat
+    }

src/Cat/Category.agda

@@ -1,142 +1,625 @@
+-- | Univalent categories
+--
+-- This module defines:
+--
+-- Categories
+-- ==========
+--
+-- Types
+-- ------
+--
+-- Object, Arrow
+--
+-- Data
+-- ----
+-- identity; the identity arrow
+-- _<<<_; function composition
+--
+-- Laws
+-- ----
+--
+-- associativity, identity, arrows form sets, univalence.
+--
+-- Lemmas
+-- ------
+--
+-- Propositionality for all laws about the category.
 {-# OPTIONS --cubical #-}
 
 module Cat.Category where
 
-open import Agda.Primitive
-open import Data.Unit.Base
-open import Data.Product renaming (proj₁ to fst ; proj₂ to snd)
-open import Data.Empty
-open import Function
-open import Cubical
+open import Cat.Prelude
+import Cat.Equivalence
+open Cat.Equivalence public using () renaming (Isomorphism to TypeIsomorphism)
+open Cat.Equivalence
+  hiding (preorder≅ ; Isomorphism)
 
-postulate undefined : {ℓ : Level} → {A : Set ℓ} → A
+------------------
+-- * Categories --
+------------------
 
-record Category {ℓ ℓ'} : Set (lsuc (ℓ' ⊔ ℓ)) where
-  constructor category
+-- | Raw categories
+--
+-- This record desribes the data that a category consist of as well as some laws
+-- about these. The laws defined are the types the propositions - not the
+-- witnesses to them!
+record RawCategory (ℓa ℓb : Level) : Set (lsuc (ℓa ⊔ ℓb)) where
+--  no-eta-equality
   field
-    Object : Set ℓ
-    Arrow  : Object → Object → Set ℓ'
-    𝟙      : {o : Object} → Arrow o o
-    _⊕_    : { a b c : Object } → Arrow b c → Arrow a b → Arrow a c
-    assoc : { A B C D : Object } { f : Arrow A B } { g : Arrow B C } { h : Arrow C D }
-      → h ⊕ (g ⊕ f) ≡ (h ⊕ g) ⊕ f
-    ident  : { A B : Object } { f : Arrow A B }
-      → f ⊕ 𝟙 ≡ f × 𝟙 ⊕ f ≡ f
-  infixl 45 _⊕_
-  domain : { a b : Object } → Arrow a b → Object
-  domain {a = a} _ = a
-  codomain : { a b : Object } → Arrow a b → Object
-  codomain {b = b} _ = b
+    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
 
-open Category public
+  -- infixr 8 _<<<_
+  -- infixl 8 _>>>_
+  infixl 10 _<<<_ _>>>_
 
-module _ {ℓ ℓ' : Level} {ℂ : Category {ℓ} {ℓ'}} { A B : Object ℂ } where
-  private
-    open module ℂ = Category ℂ
-    _+_ = ℂ._⊕_
+  -- | Reverse arrow composition
+  _>>>_ : {A B C : Object} → (Arrow A B) → (Arrow B C) → Arrow A C
+  f >>> g = g <<< f
 
-  Isomorphism : (f : ℂ.Arrow A B) → Set ℓ'
-  Isomorphism f = Σ[ g ∈ ℂ.Arrow B A ] g + f ≡ ℂ.𝟙 × f + g ≡ ℂ.𝟙
+  -- | Laws about the data
 
-  Epimorphism : {X : ℂ.Object } → (f : ℂ.Arrow A B) → Set ℓ'
-  Epimorphism {X} f = ( g₀ g₁ : ℂ.Arrow B X ) → g₀ + f ≡ g₁ + f → g₀ ≡ g₁
+  -- FIXME It seems counter-intuitive that the normal-form is on the
+  -- 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
 
-  Monomorphism : {X : ℂ.Object} → (f : ℂ.Arrow A B) → Set ℓ'
-  Monomorphism {X} f = ( g₀ g₁ : ℂ.Arrow X A ) → f + g₀ ≡ f + g₁ → g₀ ≡ g₁
+  IsIdentity : ({A : Object} → Arrow A A) → Set (ℓa ⊔ ℓb)
+  IsIdentity id = {A B : Object} {f : Arrow A B}
+    → id <<< f ≡ f × f <<< id ≡ f
 
-  iso-is-epi : ∀ {X} (f : ℂ.Arrow A B) → Isomorphism f → Epimorphism {X = X} f
-  -- Idea: Pre-compose with f- on both sides of the equality of eq to get
-  -- g₀ + f + f- ≡ g₁ + f + f-
-  -- which by left-inv reduces to the goal.
-  iso-is-epi f (f- , left-inv , right-inv) g₀ g₁ eq =
-     trans (sym (fst ℂ.ident))
-       ( trans (cong (_+_ g₀) (sym right-inv))
-         ( trans ℂ.assoc
-           ( trans (cong (λ x → x + f-) eq)
-             ( trans (sym ℂ.assoc)
-               ( trans (cong (_+_ g₁) right-inv) (fst ℂ.ident))
-             )
-           )
-         )
-       )
+  ArrowsAreSets : Set (ℓa ⊔ ℓb)
+  ArrowsAreSets = ∀ {A B : Object} → isSet (Arrow A B)
 
-  iso-is-mono : ∀ {X} (f : ℂ.Arrow A B ) → Isomorphism f → Monomorphism {X = X} f
-  -- For the next goal we do something similar: Post-compose with f- and use
-  -- right-inv to get the goal.
-  iso-is-mono f (f- , (left-inv , right-inv)) g₀ g₁ eq =
-    trans (sym (snd ℂ.ident))
-      ( trans (cong (λ x → x + g₀) (sym left-inv))
-        ( trans (sym ℂ.assoc)
-          ( trans (cong (_+_ f-) eq)
-            ( trans ℂ.assoc
-              ( trans (cong (λ x → x + g₁) left-inv) (snd ℂ.ident)
-              )
+  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)
+
+  module _ {A B : Object} where
+    Epimorphism : (f : Arrow A B) → Set _
+    Epimorphism f = ∀ {X} → (g₀ g₁ : Arrow B X) → g₀ <<< f ≡ g₁ <<< f → g₀ ≡ g₁
+
+    Monomorphism : (f : Arrow A B) → Set _
+    Monomorphism f = ∀ {X} → (g₀ g₁ : Arrow X A) → f <<< g₀ ≡ f <<< g₁ → g₀ ≡ g₁
+
+  IsInitial  : Object → Set (ℓa ⊔ ℓb)
+  IsInitial  I = {X : Object} → isContr (Arrow I X)
+
+  IsTerminal : Object → Set (ℓa ⊔ ℓb)
+  IsTerminal T = {X : Object} → isContr (Arrow X T)
+
+  Initial  : Set (ℓa ⊔ ℓb)
+  Initial  = Σ Object IsInitial
+
+  Terminal : Set (ℓa ⊔ ℓb)
+  Terminal = Σ Object IsTerminal
+
+  -- | Univalence is indexed by a raw category as well as an identity proof.
+  module Univalence (isIdentity : IsIdentity identity) where
+    -- | The identity isomorphism
+    idIso : (A : Object) → A ≊ A
+    idIso A = identity , identity , isIdentity
+
+    -- | Extract an isomorphism from an equality
+    --
+    -- [HoTT §9.1.4]
+    idToIso : (A B : Object) → A ≡ B → A ≊ B
+    idToIso A B eq = subst {P = λ X → A ≊ X} eq (idIso A)
+
+    Univalent : Set (ℓa ⊔ ℓb)
+    Univalent = {A B : Object} → isEquiv (A ≡ B) (A ≊ B) (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)
+
+    private
+      -- | Equivalent formulation of univalence.
+      Univalent[Contr] : Set _
+      Univalent[Contr] = ∀ A → isContr (Σ[ X ∈ Object ] A ≊ X)
+
+      from[Contr] : Univalent[Contr] → Univalent
+      from[Contr] = ContrToUniv.lemma _ _
+        where
+        open import Cubical.Fiberwise
+
+    univalenceFrom≃ : Univalent≃ → Univalent
+    univalenceFrom≃ = from[Contr] ∘ step
+      where
+      module _ (f : Univalent≃) (A : Object) where
+        lem : Σ Object (A ≡_) ≃ Σ Object (A ≊_)
+        lem = equivSig λ _ → f
+
+        aux : isContr (Σ Object (A ≡_))
+        aux = (A , refl) , (λ y → contrSingl (snd y))
+
+        step : isContr (Σ Object (A ≊_))
+        step = equivPreservesNType {n = ⟨-2⟩} lem aux
+
+    univalenceFrom≅ : Univalent≅ → Univalent
+    univalenceFrom≅ x = univalenceFrom≃ $ fromIsomorphism _ _ x
+
+    propUnivalent : isProp Univalent
+    propUnivalent a b i .equiv-proof = propPi (λ iso → propIsContr) (a .equiv-proof) (b .equiv-proof) i
+
+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 f
+      iso→epi (f- , left-inv , right-inv) g₀ g₁ eq = begin
+        g₀                  ≡⟨ sym rightIdentity ⟩
+        g₀ <<< identity     ≡⟨ cong (_<<<_ g₀) (sym right-inv) ⟩
+        g₀ <<< (f <<< f-)   ≡⟨ isAssociative ⟩
+        (g₀ <<< f) <<< f-   ≡⟨ cong (λ φ → φ <<< f-) eq ⟩
+        (g₁ <<< f) <<< f-   ≡⟨ sym isAssociative ⟩
+        g₁ <<< (f <<< f-)   ≡⟨ cong (_<<<_ g₁) right-inv ⟩
+        g₁ <<< identity     ≡⟨ rightIdentity ⟩
+        g₁                  ∎
+
+      iso→mono : Isomorphism f → Monomorphism f
+      iso→mono (f- , left-inv , right-inv) g₀ g₁ eq =
+        begin
+        g₀                ≡⟨ sym leftIdentity ⟩
+        identity <<< g₀   ≡⟨ cong (λ φ → φ <<< g₀) (sym left-inv) ⟩
+        (f- <<< f) <<< g₀ ≡⟨ sym isAssociative ⟩
+        f- <<< (f <<< g₀) ≡⟨ cong (_<<<_ f-) eq ⟩
+        f- <<< (f <<< g₁) ≡⟨ isAssociative ⟩
+        (f- <<< f) <<< g₁ ≡⟨ cong (λ φ → φ <<< g₁) left-inv ⟩
+        identity <<< g₁   ≡⟨ leftIdentity ⟩
+        g₁                ∎
+
+      iso→epi×mono : Isomorphism f → Epimorphism f × Monomorphism f
+      iso→epi×mono iso = iso→epi iso , iso→mono iso
+
+    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≊ }
 
-  iso-is-epi-mono : ∀ {X} (f : ℂ.Arrow A B ) → Isomorphism f → Epimorphism {X = X} f × Monomorphism {X = X} f
-  iso-is-epi-mono f iso = iso-is-epi f iso , iso-is-mono f iso
+      preorder≊ : Preorder _ _ _
+      preorder≊ = record { Carrier = Object ; _≈_ = _≡_ ; _∼_ = _≊_ ; isPreorder = isPreorder }
 
-{-
-epi-mono-is-not-iso : ∀ {ℓ ℓ'} → ¬ ((ℂ : Category {ℓ} {ℓ'}) {A B X : Object ℂ} (f : Arrow ℂ A B ) → Epimorphism {ℂ = ℂ} {X = X} f → Monomorphism {ℂ = ℂ} {X = X} f → Isomorphism {ℂ = ℂ} f)
-epi-mono-is-not-iso f =
-  let k = f {!!} {!!} {!!} {!!}
-  in {!!}
--}
+  record PreCategory : Set (lsuc (ℓa ⊔ ℓb)) where
+    field
+      isPreCategory  : IsPreCategory
+    open IsPreCategory isPreCategory public
 
--- Isomorphism of objects
-_≅_ : { ℓ ℓ' : Level } → { ℂ : Category {ℓ} {ℓ'} } → ( A B : Object ℂ ) → Set ℓ'
-_≅_ {ℂ = ℂ} A B = Σ[ f ∈ ℂ.Arrow A B ] (Isomorphism {ℂ = ℂ} f)
-  where
-    open module ℂ = Category ℂ
+  -- Definition 9.6.1 in [HoTT]
+  record StrictCategory : Set (lsuc (ℓa ⊔ ℓb)) where
+    field
+      preCategory : PreCategory
+    open PreCategory preCategory
+    field
+      objectsAreSets : isSet Object
 
-Product : {ℓ : Level} → ( C D : Category {ℓ} {ℓ} ) → Category {ℓ} {ℓ}
-Product C D =
-  record
-    { Object = C.Object × D.Object
-    ; Arrow = λ { (c , d) (c' , d') →
-      let carr = C.Arrow c c'
-          darr = D.Arrow d d'
-      in carr × darr}
-    ; 𝟙 = C.𝟙 , D.𝟙
-    ; _⊕_ = λ { (bc∈C , bc∈D) (ab∈C , ab∈D) → bc∈C C.⊕ ab∈C , bc∈D D.⊕ ab∈D}
-    ; assoc = eqpair C.assoc D.assoc
-    ; ident =
-      let (Cl , Cr) = C.ident
-          (Dl , Dr) = D.ident
-      in eqpair Cl Dl , eqpair Cr Dr
-    }
-  where
-    open module C = Category C
-    open module D = Category D
-    -- Two pairs are equal if their components are equal.
-    eqpair : {ℓ : Level} → { A : Set ℓ } → { B : Set ℓ } → { a a' : A } → { b b' : B } → a ≡ a' → b ≡ b' → (a , b) ≡ (a' , b')
-    eqpair {a = a} {b = b} eqa eqb = subst eqa (subst eqb (refl {x = (a , b)}))
+  record IsCategory : Set (lsuc (ℓa ⊔ ℓb)) where
+    field
+      isPreCategory : IsPreCategory
+    open IsPreCategory isPreCategory public
+    field
+      univalent : Univalent
 
-Opposite : ∀ {ℓ ℓ'} → Category {ℓ} {ℓ'} → Category {ℓ} {ℓ'}
-Opposite ℂ =
-  record
-    { Object = ℂ.Object
-    ; Arrow = λ A B → ℂ.Arrow B A
-    ; 𝟙 = ℂ.𝟙
-    ; _⊕_ = λ g f → f ℂ.⊕ g
-    ; assoc = sym ℂ.assoc
-    ; ident = swap ℂ.ident
-    }
-  where
-    open module ℂ = Category ℂ
+    -- | The formulation of univalence expressed with _≃_ is trivially admissable -
+    -- just "forget" the equivalence.
+    univalent≃ : Univalent≃
+    univalent≃ = _ , univalent
 
-Hom : {ℓ ℓ' : Level} → (ℂ : Category {ℓ} {ℓ'}) → (A B : Object ℂ) → Set ℓ'
-Hom ℂ A B = Arrow ℂ A B
+    module _ {A B : Object} where
+      private
+        iso : TypeIsomorphism (idToIso A B)
+        iso = toIso _ _ univalent
 
-module _ {ℓ ℓ' : Level} {ℂ : Category {ℓ} {ℓ'}} where
+      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
-    Obj = Object ℂ
-    Arr = Arrow ℂ
-    _+_ = _⊕_ ℂ
+    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
 
-  HomFromArrow : (A : Obj) → {B B' : Obj} → (g : Arr B B')
-    → Hom ℂ A B → Hom ℂ A B'
-  HomFromArrow _A g = λ f → g + f
+      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
+      -- 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.
+
+      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.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
+    {{isCategory}} : IsCategory raw
+
+  open IsCategory isCategory public
+
+-- The fact that being a category is a mere proposition gives rise to this
+-- equality principle for categories.
+module _ {ℓa ℓb : Level} {ℂ 𝔻 : Category ℓa ℓb} where
+  private
+    module ℂ = Category ℂ
+    module 𝔻 = Category 𝔻
+
+  module _ (rawEq : ℂ.raw ≡ 𝔻.raw) where
+    private
+      isCategoryEq : (λ i → IsCategory (rawEq i)) [ ℂ.isCategory ≡ 𝔻.isCategory ]
+      isCategoryEq = lemPropF {A = RawCategory _ _} {B = IsCategory} propIsCategory rawEq
+
+    Category≡ : ℂ ≡ 𝔻
+    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
+  open Category ℂ
+  _[_,_] : (A : Object) → (B : Object) → Set ℓb
+  _[_,_] = Arrow
+
+  _[_∘_] : {A B C : Object} → (g : Arrow B C) → (f : Arrow A B) → Arrow A C
+  _[_∘_] = _<<<_

src/Cat/Category/Bij.agda

@@ -1,43 +0,0 @@
-{-# OPTIONS --cubical #-}
-
-open import Cubical.PathPrelude hiding ( Id )
-
-module _ {A : Set} {a : A} {P : A → Set} where
-  Q : A → Set
-  Q a = A
-
-  t : Σ[ a ∈ A ] P a → Q a
-  t (a , Pa) = a
-  u : Q a → Σ[ a ∈ A ] P a
-  u a = a , {!!}
-
-  tu-bij : (a : Q a) → (t ∘ u) a ≡ a
-  tu-bij a = refl
-
-  v : P a → Q a
-  v x = {!!}
-  w : Q a → P a
-  w x = {!!}
-
-  vw-bij : (a : P a) → (w ∘ v) a ≡ a
-  vw-bij a = refl
-  -- tubij a with (t ∘ u) a
-  -- ... | q = {!!}
-
-  data Id {A : Set} (a : A) : Set where
-    id : A → Id a
-
-  data Id' {A : Set} (a : A) : Set where
-    id' : A → Id' a
-
-  T U : Set
-  T = Id a
-  U = Id' a
-
-  f : T → U
-  f (id x) = id' x
-  g : U → T
-  g (id' x) = id x
-
-  fg-bij : (x : U) → (f ∘ g) x ≡ x
-  fg-bij (id' x) = {!!}

src/Cat/Category/CartesianClosed.agda

@@ -0,0 +1,12 @@
+module Cat.Category.CartesianClosed where
+
+open import Agda.Primitive
+
+open import Cat.Category
+open import Cat.Category.Product
+open import Cat.Category.Exponential
+
+record CartesianClosed {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') : Set (ℓ ⊔ ℓ') where
+  field
+    {{hasProducts}}     : HasProducts ℂ
+    {{hasExponentials}} : HasExponentials ℂ

src/Cat/Category/Exponential.agda

@@ -0,0 +1,42 @@
+module Cat.Category.Exponential where
+
+open import Cat.Prelude hiding (_×_)
+
+open import Cat.Category
+open import Cat.Category.Product
+
+module _ {ℓ ℓ'} (ℂ : Category ℓ ℓ') {{hasProducts : HasProducts ℂ}} where
+  open Category ℂ
+  open HasProducts hasProducts public
+
+  module _ (B C : Object) where
+    record IsExponential'
+      (Cᴮ : Object)
+      (eval : ℂ [ Cᴮ × B , C ]) : Set (ℓ ⊔ ℓ') where
+      field
+        uniq
+          : ∀ (A : Object) (f : ℂ [ A × B , C ])
+          → ∃![ 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.identity ℂ ] ≡ f)
+
+    record Exponential : Set (ℓ ⊔ ℓ') where
+      field
+        -- obj ≡ Cᴮ
+        obj : Object
+        eval : ℂ [ obj × B , C ]
+        {{isExponential}} : IsExponential obj eval
+
+      transpose : (A : Object) → ℂ [ A × B , C ] → ℂ [ A , obj ]
+      transpose A f = fst (isExponential A f)
+
+record HasExponentials {ℓ ℓ' : Level} (ℂ : Category ℓ ℓ') {{_ : HasProducts ℂ}} : Set (ℓ ⊔ ℓ') where
+  open Category ℂ
+  open Exponential public
+  field
+    exponent : (A B : Object) → Exponential ℂ A B
+
+  _⇑_ : (A B : Object) → Object
+  A ⇑ B = (exponent A B) .obj

src/Cat/Category/Free.agda

@@ -1,38 +0,0 @@
-module Category.Free where
-
-open import Agda.Primitive
-open import Cubical.PathPrelude hiding (Path)
-
-open import Category as C
-
-module _ {ℓ ℓ' : Level} (ℂ : Category {ℓ} {ℓ'}) where
-  private
-    open module ℂ = Category ℂ
-    Obj = ℂ.Object
-
-  Path : ( a b : Obj ) → Set
-  Path a b = undefined
-
-  postulate emptyPath : (o : Obj) → Path o o
-
-  postulate concatenate : {a b c : Obj} → Path b c → Path a b → Path a c
-
-  private
-    module _ {A B C D : Obj} {r : Path A B} {q : Path B C} {p : Path C D} where
-      postulate
-        p-assoc : concatenate {A} {C} {D} p (concatenate {A} {B} {C} q r)
-          ≡ concatenate {A} {B} {D} (concatenate {B} {C} {D} p q) r
-    module _ {A B : Obj} {p : Path A B} where
-      postulate
-        ident-r : concatenate {A} {A} {B} p (emptyPath A) ≡ p
-        ident-l : concatenate {A} {B} {B} (emptyPath B) p ≡ p
-
-  Free : Category
-  Free = record
-    { Object = Obj
-    ; Arrow = Path
-    ; 𝟙 = λ {o} → emptyPath o
-    ; _⊕_ = λ {a b c} → concatenate {a} {b} {c}
-    ; assoc = p-assoc
-    ; ident = ident-r , ident-l
-    }

src/Cat/Category/Functor.agda

@@ -0,0 +1,200 @@
+{-# OPTIONS --cubical #-}
+module Cat.Category.Functor where
+
+open import Cat.Prelude
+
+open import Cubical
+
+open import Cat.Category
+
+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
+  Fmap : Omap → Set _
+  Fmap omap = ∀ {A B}
+    → ℂ [ A , B ] → 𝔻 [ omap A , omap B ]
+  record RawFunctor : 𝓤 where
+    field
+      omap : ℂ.Object → 𝔻.Object
+      fmap : ∀ {A B} → ℂ [ A , B ] → 𝔻 [ omap A , omap B ]
+
+    IsIdentity : Set _
+    IsIdentity = {A : ℂ.Object} → fmap (ℂ.identity {A}) ≡ 𝔻.identity {omap A}
+
+    IsDistributive : Set _
+    IsDistributive = {A B C : ℂ.Object} {f : ℂ [ A , B ]} {g : ℂ [ B , C ]}
+      → fmap (ℂ [ g ∘ f ]) ≡ 𝔻 [ fmap g ∘ fmap f ]
+
+  -- | Equality principle for raw functors
+  --
+  -- The type of `fmap` depend on the value of `omap`. We can wrap this up
+  -- into an equality principle for this type like is done for e.g. `Σ` using
+  -- `pathJ`.
+  module _ {x y : RawFunctor} where
+    open RawFunctor
+    private
+      P : (omap' : Omap) → (eq : omap x ≡ omap') → Set _
+      P y eq = (fmap' : Fmap y) → (λ i → Fmap (eq i))
+        [ fmap x ≡ fmap' ]
+    module _
+        (eq : (λ i → Omap) [ omap x ≡ omap y ])
+        (kk : P (omap x) refl)
+        where
+      private
+        p : P (omap y) eq
+        p = pathJ P kk (omap y) eq
+        eq→ : (λ i → Fmap (eq i)) [ fmap x ≡ fmap y ]
+        eq→ = p (fmap y)
+      RawFunctor≡ : x ≡ y
+      omap (RawFunctor≡ i) = eq  i
+      fmap (RawFunctor≡ i) = eq→ i
+
+  record IsFunctor (F : RawFunctor) : 𝓤 where
+    open RawFunctor F public
+    field
+      -- FIXME Really ought to be preserves identity or something like this.
+      isIdentity : IsIdentity
+      isDistributive : IsDistributive
+
+  record Functor : Set (ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd') where
+    field
+      raw : RawFunctor
+      {{isFunctor}} : IsFunctor raw
+
+    open IsFunctor isFunctor public
+
+EndoFunctor : ∀ {ℓa ℓb} (ℂ : Category ℓa ℓb) → Set _
+EndoFunctor ℂ = Functor ℂ ℂ
+
+module _
+    {ℓc ℓc' ℓd ℓd' : Level}
+    {ℂ : Category ℓc ℓc'} {𝔻 : Category ℓd ℓd'}
+    (F : RawFunctor ℂ 𝔻)
+    where
+  private
+    module 𝔻 = Category 𝔻
+
+  propIsFunctor : isProp (IsFunctor _ _ F)
+  propIsFunctor isF0 isF1 i = record
+    { isIdentity     = 𝔻.arrowsAreSets _ _ isF0.isIdentity     isF1.isIdentity     i
+    ; isDistributive = 𝔻.arrowsAreSets _ _ isF0.isDistributive isF1.isDistributive i
+    }
+    where
+      module isF0 = IsFunctor isF0
+      module isF1 = IsFunctor isF1
+
+-- Alternate version of above where `F` is indexed by an interval
+module _
+    {ℓc ℓc' ℓd ℓd' : Level} {ℂ : Category ℓc ℓc'} {𝔻 : Category ℓd ℓd'}
+    {F : I → RawFunctor ℂ 𝔻}
+    where
+  private
+    module 𝔻 = Category 𝔻
+  IsProp' : {ℓ : Level} (A : I → Set ℓ) → Set ℓ
+  IsProp' A = (a0 : A i0) (a1 : A i1) → A [ a0 ≡ a1 ]
+
+  IsFunctorIsProp' : IsProp' λ i → IsFunctor _ _ (F i)
+  IsFunctorIsProp' isF0 isF1 = lemPropF {B = IsFunctor ℂ 𝔻}
+    (\ F → propIsFunctor F) (\ i → F i)
+
+module _ {ℓc ℓc' ℓd ℓd' : Level} {ℂ : Category ℓc ℓc'} {𝔻 : Category ℓd ℓd'} where
+  open Functor
+  Functor≡ : {F G : Functor ℂ 𝔻}
+    → Functor.raw F ≡ Functor.raw G
+    → F ≡ G
+  Functor.raw       (Functor≡ eq i) = eq i
+  Functor.isFunctor (Functor≡ {F} {G} eq i)
+    = res i
+    where
+    res : (λ i →  IsFunctor ℂ 𝔻 (eq i)) [ isFunctor F ≡ isFunctor G ]
+    res = IsFunctorIsProp' (isFunctor F) (isFunctor G)
+
+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 : 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 ])
+          ≡⟨ refl ⟩
+        F.fmap (G.fmap (A [ α1 ∘ α0 ]))
+          ≡⟨ cong F.fmap G.isDistributive ⟩
+        F.fmap (B [ G.fmap α1 ∘ G.fmap α0 ])
+          ≡⟨ F.isDistributive ⟩
+        C [ (F.fmap ∘ G.fmap) α1 ∘ (F.fmap ∘ G.fmap) α0 ]
+          ∎
+
+    raw : RawFunctor A C
+    RawFunctor.omap raw = F.omap ∘ G.omap
+    RawFunctor.fmap raw = F.fmap ∘ G.fmap
+
+    isFunctor : IsFunctor A C raw
+    isFunctor = record
+      { isIdentity = begin
+        (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
+      }
+
+  F[_∘_] : Functor A C
+  Functor.raw       F[_∘_] = raw
+  Functor.isFunctor F[_∘_] = isFunctor
+
+-- | 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

src/Cat/Category/Monad.agda

@@ -0,0 +1,240 @@
+{---
+Monads
+
+This module presents two formulations of monads:
+
+  * The standard monoidal presentation
+  * Kleisli's presentation
+
+The first one defines a monad in terms of an endofunctor and two natural
+transformations. The second defines it in terms of a function on objects and a
+pair of arrows.
+
+These two formulations are proven to be equivalent:
+
+    Monoidal.Monad ≃ Kleisli.Monad
+
+The monoidal representation is exposed by default from this module.
+ ---}
+
+{-# OPTIONS --cubical #-}
+module Cat.Category.Monad where
+
+open import Cat.Prelude
+open import Cat.Category
+open import Cat.Category.Functor as F
+import Cat.Category.NaturalTransformation
+import Cat.Category.Monad.Monoidal
+import Cat.Category.Monad.Kleisli
+open import Cat.Categories.Fun
+
+-- | 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 ; identity ; _<<<_ ; _>>>_)
+
+    module Monoidal = Cat.Category.Monad.Monoidal ℂ
+    module Kleisli  = Cat.Category.Monad.Kleisli ℂ
+
+    module _ (m : Monoidal.RawMonad) where
+      open Monoidal.RawMonad m
+
+      toKleisliRaw : Kleisli.RawMonad
+      Kleisli.RawMonad.omap toKleisliRaw = Romap
+      Kleisli.RawMonad.pure toKleisliRaw = pure
+      Kleisli.RawMonad.bind toKleisliRaw = bind
+
+    module _ {raw : Monoidal.RawMonad} (m : Monoidal.IsMonad raw) where
+      open Monoidal.IsMonad m
+
+      open Kleisli.RawMonad (toKleisliRaw raw) using (_>=>_)
+      toKleisliIsMonad : Kleisli.IsMonad (toKleisliRaw raw)
+      Kleisli.IsMonad.isIdentity     toKleisliIsMonad = begin
+        bind pure ≡⟨⟩
+        join <<< (fmap pure) ≡⟨ snd isInverse ⟩
+        identity ∎
+      Kleisli.IsMonad.isNatural      toKleisliIsMonad f = begin
+        pure >=> f ≡⟨⟩
+        pure >>> bind f ≡⟨⟩
+        bind f <<< pure ≡⟨⟩
+        (join <<< fmap f) <<< pure ≡⟨ isNatural f ⟩
+        f ∎
+      Kleisli.IsMonad.isDistributive toKleisliIsMonad f g = begin
+        bind g >>> bind f ≡⟨⟩
+        (join <<< fmap f) <<< (join <<< fmap g) ≡⟨ isDistributive f g ⟩
+        join <<< fmap (join <<< fmap f <<< g) ≡⟨⟩
+        bind (g >=> f) ∎
+      -- Kleisli.IsMonad.isDistributive toKleisliIsMonad = isDistributive
+
+    toKleisli : Monoidal.Monad → Kleisli.Monad
+    Kleisli.Monad.raw     (toKleisli m) = toKleisliRaw     (Monoidal.Monad.raw     m)
+    Kleisli.Monad.isMonad (toKleisli m) = toKleisliIsMonad (Monoidal.Monad.isMonad m)
+
+    module _ (m : Kleisli.Monad) where
+      open Kleisli.Monad m
+
+      toMonoidalRaw : Monoidal.RawMonad
+      Monoidal.RawMonad.R      toMonoidalRaw = R
+      Monoidal.RawMonad.pureNT toMonoidalRaw = pureNT
+      Monoidal.RawMonad.joinNT toMonoidalRaw = joinNT
+
+      open Monoidal.RawMonad toMonoidalRaw renaming
+        ( join to join*
+        ; pure to pure*
+        ; bind to bind*
+        ; fmap to fmap*
+        ) using ()
+
+      toMonoidalIsMonad : Monoidal.IsMonad toMonoidalRaw
+      Monoidal.IsMonad.isAssociative toMonoidalIsMonad = begin
+        join* <<< fmap join* ≡⟨⟩
+        join  <<< fmap join    ≡⟨ isNaturalForeign ⟩
+        join  <<< join         ∎
+      Monoidal.IsMonad.isInverse toMonoidalIsMonad {X} = inv-l , inv-r
+        where
+        inv-l = begin
+          join <<< pure                ≡⟨ fst isInverse ⟩
+          identity                     ∎
+        inv-r = begin
+          join* <<< fmap* pure*        ≡⟨⟩
+          join <<< fmap pure           ≡⟨ snd isInverse ⟩
+          identity                     ∎
+
+    toMonoidal : Kleisli.Monad → Monoidal.Monad
+    Monoidal.Monad.raw     (toMonoidal m) = toMonoidalRaw     m
+    Monoidal.Monad.isMonad (toMonoidal m) = toMonoidalIsMonad m
+
+    module _ (m : Kleisli.Monad) where
+      private
+        open Kleisli.Monad m
+        bindEq : ∀ {X Y}
+          → Kleisli.RawMonad.bind (toKleisliRaw (toMonoidalRaw m)) {X} {Y}
+          ≡ bind
+        bindEq {X} {Y} = funExt lem
+          where
+          lem : (f : Arrow X (omap Y))
+            → bind (f >>> pure) >>> bind identity
+            ≡ bind f
+          lem f = begin
+            join <<< fmap f
+              ≡⟨⟩
+            bind (f >>> pure) >>> bind identity
+              ≡⟨ isDistributive _ _ ⟩
+            bind ((f >>> pure) >=> identity)
+              ≡⟨⟩
+            bind ((f >>> pure) >>> bind identity)
+              ≡⟨ cong bind ℂ.isAssociative ⟩
+            bind (f >>> (pure >>> bind identity))
+              ≡⟨⟩
+            bind (f >>> (pure >=> identity))
+              ≡⟨ cong (λ φ → bind (f >>> φ)) (isNatural _) ⟩
+            bind (f >>> identity)
+              ≡⟨ cong bind ℂ.leftIdentity ⟩
+            bind f ∎
+
+      toKleisliRawEq : toKleisliRaw (toMonoidalRaw m) ≡ Kleisli.Monad.raw m
+      Kleisli.RawMonad.omap  (toKleisliRawEq i) = (begin
+          Kleisli.RawMonad.omap (toKleisliRaw (toMonoidalRaw m)) ≡⟨⟩
+          Monoidal.RawMonad.Romap (toMonoidalRaw m) ≡⟨⟩
+          omap ∎
+        ) i
+      Kleisli.RawMonad.pure  (toKleisliRawEq i) = (begin
+          Kleisli.RawMonad.pure  (toKleisliRaw (toMonoidalRaw m)) ≡⟨⟩
+          Monoidal.RawMonad.pure (toMonoidalRaw m)               ≡⟨⟩
+          pure ∎
+        ) i
+      Kleisli.RawMonad.bind  (toKleisliRawEq i) = bindEq i
+
+    toKleislieq : (m : Kleisli.Monad) → toKleisli (toMonoidal m) ≡ m
+    toKleislieq m = Kleisli.Monad≡ (toKleisliRawEq m)
+
+    module _ (m : Monoidal.Monad) where
+      private
+        open Monoidal.Monad m
+        -- module KM = Kleisli.Monad (toKleisli m)
+        open Kleisli.Monad (toKleisli m) renaming
+          ( bind to bind* ; omap to omap* ; join to join*
+          ; fmap to fmap* ; pure to pure* ; R to R*)
+          using ()
+        module R = Functor R
+        omapEq : omap* ≡ Romap
+        omapEq = refl
+
+        bindEq : ∀ {X Y} {f : Arrow X (Romap Y)} → bind* f ≡ bind f
+        bindEq {X} {Y} {f} = begin
+          bind* f         ≡⟨⟩
+          join <<< fmap f ≡⟨⟩
+          bind f          ∎
+
+        joinEq : ∀ {X} → join* ≡ joinT X
+        joinEq {X} = begin
+          join*                  ≡⟨⟩
+          bind* identity         ≡⟨⟩
+          bind identity          ≡⟨⟩
+          join <<< fmap identity ≡⟨ cong (λ φ → _ <<< φ) R.isIdentity ⟩
+          join <<< identity      ≡⟨ ℂ.rightIdentity ⟩
+          join                   ∎
+
+        fmapEq : ∀ {A B} → fmap* {A} {B} ≡ fmap
+        fmapEq {A} {B} = funExt (λ f → begin
+          fmap* f                          ≡⟨⟩
+          bind* (f >>> pure*)              ≡⟨⟩
+          bind (f >>> pure)                ≡⟨⟩
+          fmap (f >>> pure) >>> join       ≡⟨⟩
+          fmap (f >>> pure) >>> join       ≡⟨ cong (λ φ → φ >>> joinT B) R.isDistributive ⟩
+          fmap f >>> fmap pure >>> join    ≡⟨ ℂ.isAssociative ⟩
+          join <<< fmap pure <<< fmap f    ≡⟨ cong (λ φ → φ <<< fmap f) (snd isInverse) ⟩
+          identity <<< fmap f              ≡⟨ ℂ.leftIdentity ⟩
+          fmap f                           ∎
+          )
+
+        rawEq : Functor.raw R* ≡ Functor.raw R
+        RawFunctor.omap (rawEq i) = omapEq i
+        RawFunctor.fmap (rawEq i) = fmapEq i
+
+      Req : Monoidal.RawMonad.R (toMonoidalRaw (toKleisli m)) ≡ R
+      Req = Functor≡ rawEq
+
+      pureTEq : Monoidal.RawMonad.pureT (toMonoidalRaw (toKleisli m)) ≡ pureT
+      pureTEq = refl
+
+      pureNTEq : (λ i → NaturalTransformation Functors.identity (Req i))
+        [ Monoidal.RawMonad.pureNT (toMonoidalRaw (toKleisli m)) ≡ pureNT ]
+      pureNTEq = lemSigP (λ i → propIsNatural Functors.identity (Req i)) _ _ pureTEq
+
+      joinTEq : Monoidal.RawMonad.joinT (toMonoidalRaw (toKleisli m)) ≡ joinT
+      joinTEq = funExt (λ X → begin
+        Monoidal.RawMonad.joinT (toMonoidalRaw (toKleisli m)) X ≡⟨⟩
+        join* ≡⟨⟩
+        join <<< fmap identity ≡⟨ cong (λ φ → join <<< φ) R.isIdentity ⟩
+        join <<< identity ≡⟨ ℂ.rightIdentity ⟩
+        join ∎)
+
+      joinNTEq : (λ i → NaturalTransformation F[ Req i ∘ Req i ] (Req i))
+        [ Monoidal.RawMonad.joinNT (toMonoidalRaw (toKleisli m)) ≡ joinNT ]
+      joinNTEq = lemSigP (λ i → propIsNatural F[ Req i ∘ Req i ] (Req i)) _ _ joinTEq
+
+      toMonoidalRawEq : toMonoidalRaw (toKleisli m) ≡ Monoidal.Monad.raw m
+      Monoidal.RawMonad.R      (toMonoidalRawEq i) = Req i
+      Monoidal.RawMonad.pureNT (toMonoidalRawEq i) = pureNTEq i
+      Monoidal.RawMonad.joinNT (toMonoidalRawEq i) = joinNTEq i
+
+    toMonoidaleq : (m : Monoidal.Monad) → toMonoidal (toKleisli m) ≡ m
+    toMonoidaleq m = Monoidal.Monad≡ (toMonoidalRawEq m)
+
+  open import Cat.Equivalence
+
+  Monoidal≊Kleisli : Monoidal.Monad ≅ Kleisli.Monad
+  Monoidal≊Kleisli = toKleisli , toMonoidal , funExt toMonoidaleq , funExt toKleislieq
+
+  Monoidal≡Kleisli : Monoidal.Monad ≡ Kleisli.Monad
+  Monoidal≡Kleisli = isoToPath Monoidal≊Kleisli
+
+  grpdKleisli : isGrpd Kleisli.Monad
+  grpdKleisli = Kleisli.grpdMonad
+
+  grpdMonoidal : isGrpd Monoidal.Monad
+  grpdMonoidal = subst {P = isGrpd}
+    (sym Monoidal≡Kleisli) grpdKleisli

src/Cat/Category/Monad/Kleisli.agda

@@ -0,0 +1,347 @@
+{---
+The Kleisli formulation of monads
+ ---}
+{-# OPTIONS --cubical #-}
+open import Agda.Primitive
+
+open import Cat.Prelude
+open import Cat.Equivalence
+
+open import Cat.Category
+open import Cat.Category.Functor as F
+open import Cat.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 ; identity ; Object ; _<<<_ ; _>>>_)
+
+-- | Data for a monad.
+--
+-- Note that (>>=) is not expressible in a general category because objects
+-- are not generally types.
+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 ]
+
+  -- | functor map
+  --
+  -- 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)
+
+  -- | Composition of monads aka. the kleisli-arrow.
+  _>=>_ : {A B C : Object} → ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ]
+  f >=> g = f >>> (bind g)
+
+  -- | Flattening nested monads.
+  join : {A : Object} → ℂ [ omap (omap A) , omap A ]
+  join = bind identity
+
+  ------------------
+  -- * Monad laws --
+  ------------------
+
+  -- There may be better names than what I've chosen here.
+
+  -- `pure` is the neutral element for `bind`
+  IsIdentity     = {X : Object}
+    → bind pure ≡ identity {omap X}
+  -- pure is the left-identity for the kleisli arrow.
+  IsNatural      = {X Y : Object}   (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
+
+  -- In the ("foreign") formulation of a monad `IsNatural`'s analogue here would be:
+  IsNaturalForeign : Set _
+  IsNaturalForeign = {X : Object} → join {X} <<< fmap join ≡ join <<< join
+
+  IsInverse : Set _
+  IsInverse = {X : Object} → join {X} <<< pure ≡ identity × join {X} <<< fmap pure ≡ identity
+
+record IsMonad (raw : RawMonad) : Set ℓ where
+  open RawMonad raw public
+  field
+    isIdentity     : IsIdentity
+    isNatural      : IsNatural
+    isDistributive : IsDistributive
+
+  -- | 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))))
+      ≡⟨⟩
+    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              ∎
+    where
+      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
+    rawR : RawFunctor ℂ ℂ
+    RawFunctor.omap rawR = omap
+    RawFunctor.fmap rawR = fmap
+
+    isFunctorR : IsFunctor ℂ ℂ rawR
+    IsFunctor.isIdentity isFunctorR = begin
+      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) ∎
+
+  -- FIXME Naming!
+  R : EndoFunctor ℂ
+  Functor.raw       R = rawR
+  Functor.isFunctor R = isFunctorR
+
+  private
+    R⁰ : EndoFunctor ℂ
+    R⁰ = Functors.identity
+    R² : EndoFunctor ℂ
+    R² = F[ R ∘ R ]
+    module R  = Functor R
+    module R⁰ = Functor R⁰
+    module R² = Functor R²
+    pureT : Transformation R⁰ R
+    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        ∎
+    joinT : Transformation R² R
+    joinT C = join
+    joinN : Natural R² R joinT
+    joinN f = begin
+      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) >=> identity)
+        ≡⟨⟩
+      bind ((bind (f >>> pure) >>> pure) >>> bind identity)
+        ≡⟨ cong bind ℂ.isAssociative ⟩
+      bind (bind (f >>> pure) >>> (pure >>> bind identity))
+        ≡⟨ cong (λ φ → bind (bind (f >>> pure) >>> φ)) (isNatural _) ⟩
+      bind (bind (f >>> pure) >>> identity)
+        ≡⟨ cong bind ℂ.leftIdentity ⟩
+      bind (bind (f >>> pure))
+        ≡⟨ cong bind (sym ℂ.rightIdentity) ⟩
+      bind (identity >>> bind (f >>> pure))   ≡⟨⟩
+      bind (identity >=> (f >>> pure))
+        ≡⟨ sym (isDistributive _ _) ⟩
+      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
+  fst pureNT = pureT
+  snd pureNT = pureN
+
+  joinNT : NaturalTransformation R² R
+  fst joinNT = joinT
+  snd joinNT = joinN
+
+  isNaturalForeign : IsNaturalForeign
+  isNaturalForeign = begin
+    fmap join >>> join ≡⟨⟩
+    bind (join >>> pure) >>> bind identity
+      ≡⟨ isDistributive _ _ ⟩
+    bind ((join >>> pure) >>> bind identity)
+      ≡⟨ cong bind ℂ.isAssociative ⟩
+    bind (join >>> (pure >>> bind identity))
+      ≡⟨ cong (λ φ → bind (join >>> φ)) (isNatural _) ⟩
+    bind (join >>> identity)
+      ≡⟨ cong bind ℂ.leftIdentity ⟩
+    bind join           ≡⟨⟩
+    bind (bind identity)
+      ≡⟨ cong bind (sym ℂ.rightIdentity) ⟩
+    bind (identity >>> bind identity) ≡⟨⟩
+    bind (identity >=> identity)      ≡⟨ sym (isDistributive _ _) ⟩
+    bind identity >>> bind identity   ≡⟨⟩
+    join >>> join       ∎
+
+  isInverse : IsInverse
+  isInverse = inv-l , inv-r
+    where
+    inv-l = begin
+      pure >>> join   ≡⟨⟩
+      pure >>> bind identity ≡⟨ isNatural _ ⟩
+      identity ∎
+    inv-r = begin
+      fmap pure >>> join ≡⟨⟩
+      bind (pure >>> pure) >>> bind identity
+        ≡⟨ isDistributive _ _ ⟩
+      bind ((pure >>> pure) >=> identity) ≡⟨⟩
+      bind ((pure >>> pure) >>> bind identity)
+        ≡⟨ cong bind ℂ.isAssociative ⟩
+      bind (pure >>> (pure >>> bind identity))
+        ≡⟨ cong (λ φ → bind (pure >>> φ)) (isNatural _) ⟩
+      bind (pure >>> identity)
+        ≡⟨ cong bind ℂ.leftIdentity ⟩
+      bind pure ≡⟨ isIdentity ⟩
+      identity ∎
+
+  rightIdentity : RightIdentity
+  rightIdentity {m = m} = begin
+    m >=> pure      ≡⟨⟩
+    m >>> bind pure ≡⟨ cong (m >>>_) isIdentity ⟩
+    m >>> identity  ≡⟨ ℂ.leftIdentity ⟩
+    m ∎
+
+record Monad : Set ℓ where
+  no-eta-equality
+  field
+    raw : RawMonad
+    isMonad : IsMonad raw
+  open IsMonad isMonad public
+
+private
+  module _ (raw : RawMonad) where
+    open RawMonad raw
+    propIsIdentity : isProp IsIdentity
+    propIsIdentity x y i = ℂ.arrowsAreSets _ _ x y i
+    propIsNatural      : isProp IsNatural
+    propIsNatural x y i = λ f
+      → ℂ.arrowsAreSets _ _ (x f) (y f) i
+    propIsDistributive : isProp IsDistributive
+    propIsDistributive x y i = λ g f
+      → ℂ.arrowsAreSets _ _ (x g f) (y g f) i
+
+  open IsMonad
+  propIsMonad : (raw : _) → isProp (IsMonad raw)
+  IsMonad.isIdentity     (propIsMonad raw x y i)
+    = propIsIdentity raw (isIdentity x) (isIdentity y) i
+  IsMonad.isNatural      (propIsMonad raw x y i)
+    = propIsNatural raw (isNatural x) (isNatural y) i
+  IsMonad.isDistributive (propIsMonad raw x y i)
+    = propIsDistributive raw (isDistributive x) (isDistributive y) i
+
+module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where
+  private
+    eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ]
+    eqIsMonad = lemPropF propIsMonad eq
+
+  Monad≡ : m ≡ n
+  Monad.raw     (Monad≡ i) = eq i
+  Monad.isMonad (Monad≡ i) = eqIsMonad i
+
+module _ where
+  private
+    module _ (x y : RawMonad) (p q : x ≡ y) (a b : p ≡ q) where
+      eq0-helper : isGrpd (Object → Object)
+      eq0-helper = grpdPi (λ a → ℂ.groupoidObject)
+
+      eq0 : cong (cong RawMonad.omap) a ≡ cong (cong RawMonad.omap) b
+      eq0 = eq0-helper
+        (RawMonad.omap x)             (RawMonad.omap y)
+        (cong RawMonad.omap p)        (cong RawMonad.omap q)
+        (cong (cong RawMonad.omap) a) (cong (cong RawMonad.omap) b)
+
+      eq1-helper : (omap : Object → Object) → isGrpd ({X : Object}   → ℂ [ X , omap X ])
+      eq1-helper f = grpdPiImpl (setGrpd ℂ.arrowsAreSets)
+
+      postulate
+        eq1 : PathP (λ i → PathP
+          (λ j →
+          PathP (λ k → {X : Object} → ℂ [ X , eq0 i j k X ])
+          (RawMonad.pure x) (RawMonad.pure y))
+          (λ i → RawMonad.pure (p i)) (λ i → RawMonad.pure (q i)))
+          (cong-d (cong-d RawMonad.pure) a) (cong-d (cong-d RawMonad.pure) b)
+
+
+    RawMonad' : Set _
+    RawMonad' = Σ (Object → Object) (λ omap
+      → ({X : Object} → ℂ [ X , omap X ])
+      × ({X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ])
+      )
+    grpdRawMonad' : isGrpd RawMonad'
+    grpdRawMonad' = grpdSig (grpdPi (λ _ → ℂ.groupoidObject)) λ _ → grpdSig (grpdPiImpl (setGrpd ℂ.arrowsAreSets)) (λ _ → grpdPiImpl (grpdPiImpl (grpdPi (λ _ → setGrpd ℂ.arrowsAreSets))))
+    toRawMonad : RawMonad' → RawMonad
+    RawMonad.omap (toRawMonad (a , b , c)) = a
+    RawMonad.pure (toRawMonad (a , b , c)) = b
+    RawMonad.bind (toRawMonad (a , b , c)) = c
+
+    IsMonad' : RawMonad' → Set _
+    IsMonad' raw = M.IsIdentity × M.IsNatural × M.IsDistributive
+      where
+      module M = RawMonad (toRawMonad raw)
+
+    grpdIsMonad' : (m : RawMonad') → isGrpd (IsMonad' m)
+    grpdIsMonad' m = grpdSig (propGrpd (propIsIdentity (toRawMonad m)))
+      λ _ → grpdSig (propGrpd (propIsNatural (toRawMonad m)))
+      λ _ → propGrpd (propIsDistributive (toRawMonad m))
+
+    Monad' = Σ RawMonad' IsMonad'
+    grpdMonad' = grpdSig grpdRawMonad' grpdIsMonad'
+
+    toMonad : Monad' → Monad
+    Monad.raw (toMonad x) = toRawMonad (fst x)
+    isIdentity (Monad.isMonad (toMonad x)) = fst (snd x)
+    isNatural (Monad.isMonad (toMonad x)) = fst (snd (snd x))
+    isDistributive (Monad.isMonad (toMonad x)) = snd (snd (snd x))
+
+    fromMonad : Monad → Monad'
+    fromMonad m = (M.omap , M.pure , M.bind)
+      , M.isIdentity , M.isNatural , M.isDistributive
+      where
+      module M = Monad m
+
+    e : Monad' ≃ Monad
+    e = fromIsomorphism _ _ (toMonad , fromMonad , (funExt λ _ → refl) , funExt eta-refl)
+      where
+      -- Monads don't have eta-equality
+      eta-refl : (x : Monad) → toMonad (fromMonad x) ≡ x
+      eta-refl =
+        (λ x → λ
+          { i .Monad.raw → Monad.raw x
+          ; i .Monad.isMonad  → Monad.isMonad x}
+        )
+
+  grpdMonad : isGrpd Monad
+  grpdMonad = equivPreservesNType
+    {n = (S (S (S ⟨-2⟩)))}
+    e grpdMonad'
+    where
+    open import Cubical.NType

src/Cat/Category/Monad/Monoidal.agda

@@ -0,0 +1,161 @@
+{---
+Monoidal formulation of monads
+ ---}
+{-# OPTIONS --cubical #-}
+open import Agda.Primitive
+
+open import Cat.Prelude
+
+open import Cat.Category
+open import Cat.Category.Functor as F
+open import Cat.Categories.Fun
+
+module Cat.Category.Monad.Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
+
+-- "A monad in the monoidal form" [voe]
+private
+  ℓ = ℓa ⊔ ℓb
+
+open Category ℂ using (Object ; Arrow ; identity ; _<<<_)
+open import Cat.Category.NaturalTransformation ℂ ℂ
+  using (NaturalTransformation ; Transformation ; Natural ; NaturalTransformation≡)
+
+record RawMonad : Set ℓ where
+  field
+    R      : EndoFunctor ℂ
+    pureNT : NaturalTransformation 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 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}
+    -- R and join commute
+    → joinT X <<< fmap join ≡ join <<< join
+  IsInverse : Set _
+  IsInverse = {X : Object}
+    -- 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))
+    → join <<< fmap g <<< (join <<< fmap f)
+    ≡ join <<< fmap (join <<< fmap g <<< f)
+
+record IsMonad (raw : RawMonad) : Set ℓ where
+  open RawMonad raw public
+  field
+    isAssociative : IsAssociative
+    isInverse     : IsInverse
+
+  private
+    module R = Functor R
+    module ℂ = Category ℂ
+
+  isNatural : IsNatural
+  isNatural {X} {Y} f = begin
+    join <<< fmap f <<< pure     ≡⟨ sym ℂ.isAssociative ⟩
+    join <<< (fmap f <<< pure)   ≡⟨ cong (λ φ → join <<< φ) (sym (pureN f)) ⟩
+    join <<< (pure <<< f)        ≡⟨ ℂ.isAssociative ⟩
+    join <<< pure <<< f          ≡⟨ cong (λ φ → φ <<< f) (fst isInverse) ⟩
+    identity <<< f               ≡⟨ ℂ.leftIdentity ⟩
+    f                            ∎
+
+  isDistributive : IsDistributive
+  isDistributive {X} {Y} {Z} g f = begin
+       join <<< fmap g <<< (join <<< fmap f)
+       ≡⟨ Category.isAssociative ℂ ⟩
+       join <<< fmap g <<< join <<< fmap f
+       ≡⟨ cong (_<<< fmap f) (sym ℂ.isAssociative) ⟩
+       (join <<< (fmap g <<< join)) <<< fmap f
+       ≡⟨ cong (λ φ → φ <<< fmap f) (cong (_<<<_ join) (sym (joinN g))) ⟩
+       (join <<< (join <<< R².fmap g)) <<< fmap f
+       ≡⟨ cong (_<<< fmap f) ℂ.isAssociative ⟩
+       ((join <<< join) <<< R².fmap g) <<< fmap f
+       ≡⟨⟩
+       join <<< join <<< R².fmap g <<< fmap f
+       ≡⟨ sym ℂ.isAssociative ⟩
+       (join <<< join) <<< (R².fmap g <<< fmap f)
+       ≡⟨ cong (λ φ → φ <<< (R².fmap g <<< fmap f)) (sym isAssociative) ⟩
+       (join <<< fmap join) <<< (R².fmap g <<< fmap f)
+       ≡⟨ sym ℂ.isAssociative ⟩
+       join <<< (fmap join <<< (R².fmap g <<< fmap f))
+       ≡⟨ cong (_<<<_ join) ℂ.isAssociative ⟩
+       join <<< (fmap join <<< R².fmap g <<< fmap f)
+       ≡⟨⟩
+       join <<< (fmap join <<< fmap (fmap g) <<< fmap f)
+       ≡⟨ cong (λ φ → join <<< φ) (sym distrib3) ⟩
+       join <<< fmap (join <<< fmap g <<< f)
+       ∎
+    where
+    module R² = Functor F[ R ∘ R ]
+    distrib3 : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B}
+      → R.fmap (a <<< b <<< c)
+      ≡ R.fmap a <<< R.fmap b <<< R.fmap c
+    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  ∎
+
+record Monad : Set ℓ where
+  no-eta-equality
+  field
+    raw     : RawMonad
+    isMonad : IsMonad raw
+  open IsMonad isMonad public
+
+private
+  module _ {m : RawMonad} where
+    open RawMonad m
+    propIsAssociative : isProp IsAssociative
+    propIsAssociative x y i {X}
+      = Category.arrowsAreSets ℂ _ _ (x {X}) (y {X}) i
+    propIsInverse : isProp IsInverse
+    propIsInverse x y i {X} = e1 i , e2 i
+      where
+      xX = x {X}
+      yX = y {X}
+      e1 = Category.arrowsAreSets ℂ _ _ (fst xX) (fst yX)
+      e2 = Category.arrowsAreSets ℂ _ _ (snd xX) (snd yX)
+
+  open IsMonad
+  propIsMonad : (raw : _) → isProp (IsMonad raw)
+  IsMonad.isAssociative (propIsMonad raw a b i) j
+    = propIsAssociative {raw}
+      (isAssociative a) (isAssociative b) i j
+  IsMonad.isInverse     (propIsMonad raw a b i)
+    = propIsInverse {raw}
+      (isInverse a) (isInverse b) i
+
+module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where
+  private
+    eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ]
+    eqIsMonad = lemPropF propIsMonad eq
+
+  Monad≡ : m ≡ n
+  Monad.raw     (Monad≡ i) = eq i
+  Monad.isMonad (Monad≡ i) = eqIsMonad i

src/Cat/Category/Monad/Voevodsky.agda

@@ -0,0 +1,246 @@
+{-
+This module provides construction 2.3 in [voe]
+-}
+{-# OPTIONS --cubical #-}
+module Cat.Category.Monad.Voevodsky where
+
+open import Cat.Prelude
+open import Cat.Equivalence
+
+open import Cat.Category
+open import Cat.Category.Functor as F
+import Cat.Category.NaturalTransformation
+open import Cat.Category.Monad
+import Cat.Category.Monad.Monoidal as Monoidal
+import Cat.Category.Monad.Kleisli as Kleisli
+open import Cat.Categories.Fun
+open import Cat.Equivalence
+
+module voe {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where
+  open Cat.Category.NaturalTransformation ℂ ℂ
+  private
+    ℓ = ℓa ⊔ ℓb
+    module ℂ = Category ℂ
+    open ℂ using (Object ; Arrow)
+    module M = Monoidal ℂ
+    module K = Kleisli  ℂ
+
+  module §2-3 (omap : Object → Object) (pure : {X : Object} → Arrow X (omap X)) where
+    record §1 : Set ℓ where
+      no-eta-equality
+      open M
+
+      field
+        fmap : Fmap ℂ ℂ omap
+        join : {A : Object} → ℂ [ omap (omap A) , omap A ]
+
+      Rraw : RawFunctor ℂ ℂ
+      Rraw = record
+        { omap = omap
+        ; fmap = fmap
+        }
+
+      field
+        RisFunctor : IsFunctor ℂ ℂ Rraw
+
+      R : EndoFunctor ℂ
+      R = record
+        { raw = Rraw
+        ; isFunctor = RisFunctor
+        }
+
+      pureT : (X : Object) → Arrow X (omap X)
+      pureT X = pure {X}
+
+      field
+        pureN : Natural Functors.identity R pureT
+
+      pureNT : NaturalTransformation Functors.identity R
+      pureNT = pureT , pureN
+
+      joinT : (A : Object) → ℂ [ omap (omap A) , omap A ]
+      joinT A = join {A}
+
+      field
+        joinN : Natural F[ R ∘ R ] R joinT
+
+      joinNT : NaturalTransformation F[ R ∘ R ] R
+      joinNT = joinT , joinN
+
+      rawMnd : RawMonad
+      rawMnd = record
+        { R = R
+        ; pureNT = pureNT
+        ; joinNT = joinNT
+        }
+
+      field
+        isMonad : IsMonad rawMnd
+
+      toMonad : Monad
+      toMonad .Monad.raw = rawMnd
+      toMonad .Monad.isMonad = isMonad
+
+    record §2 : Set ℓ where
+      no-eta-equality
+      open K
+
+      field
+        bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ]
+
+      rawMnd : RawMonad
+      rawMnd = record
+        { omap = omap
+        ; pure = pure
+        ; bind = bind
+        }
+
+      field
+        isMonad : IsMonad rawMnd
+
+      toMonad : Monad
+      toMonad .Monad.raw     = rawMnd
+      toMonad .Monad.isMonad = isMonad
+
+  module _ (m : M.Monad) where
+    open M.Monad m
+
+    §1-fromMonad : §2-3.§1 (M.Monad.Romap m) (λ {X} → M.Monad.pureT m X)
+    §1-fromMonad .§2-3.§1.fmap       = Functor.fmap R
+    §1-fromMonad .§2-3.§1.RisFunctor = Functor.isFunctor R
+    §1-fromMonad .§2-3.§1.pureN      = pureN
+    §1-fromMonad .§2-3.§1.join      {X} = joinT X
+    §1-fromMonad .§2-3.§1.joinN      = joinN
+    §1-fromMonad .§2-3.§1.isMonad    = M.Monad.isMonad m
+
+
+  §2-fromMonad : (m : K.Monad) → §2-3.§2 (K.Monad.omap m) (K.Monad.pure m)
+  §2-fromMonad m .§2-3.§2.bind    = K.Monad.bind    m
+  §2-fromMonad m  .§2-3.§2.isMonad = K.Monad.isMonad m
+
+  -- | In the following we seek to transform the equivalence `Monoidal≃Kleisli`
+  -- | to talk about voevodsky's construction.
+  module _ (omap : Omap ℂ ℂ) (pure : {X : Object} → Arrow X (omap X)) where
+    private
+      module E = AreInverses {f = (fst (Monoidal≊Kleisli ℂ))} {fst (snd (Monoidal≊Kleisli ℂ))}(Monoidal≊Kleisli ℂ .snd .snd)
+
+      Monoidal→Kleisli : M.Monad → K.Monad
+      Monoidal→Kleisli = E.obverse
+
+      Kleisli→Monoidal : K.Monad → M.Monad
+      Kleisli→Monoidal = E.reverse
+
+      ve-re : Kleisli→Monoidal ∘ Monoidal→Kleisli ≡ idFun _
+      ve-re = E.verso-recto
+
+      re-ve : Monoidal→Kleisli ∘ Kleisli→Monoidal ≡ idFun _
+      re-ve = E.recto-verso
+
+      forth : §2-3.§1 omap pure → §2-3.§2 omap pure
+      forth = §2-fromMonad ∘ Monoidal→Kleisli ∘ §2-3.§1.toMonad
+
+      back : §2-3.§2 omap pure → §2-3.§1 omap pure
+      back = §1-fromMonad ∘ Kleisli→Monoidal ∘ §2-3.§2.toMonad
+
+      forthEq : ∀ m → (forth ∘ back) m ≡ m
+      forthEq m = begin
+       §2-fromMonad
+         (Monoidal→Kleisli
+          (§2-3.§1.toMonad
+           (§1-fromMonad (Kleisli→Monoidal (§2-3.§2.toMonad m)))))
+         ≡⟨ cong-d (§2-fromMonad ∘ Monoidal→Kleisli) (lemmaz (Kleisli→Monoidal (§2-3.§2.toMonad m))) ⟩
+       §2-fromMonad
+         ((Monoidal→Kleisli ∘ Kleisli→Monoidal)
+          (§2-3.§2.toMonad m))
+         -- Below is the fully normalized goal and context with
+         -- `funExt` made abstract.
+         --
+         -- Goal: PathP (λ _ → §2-3.§2 omap (λ {z} → pure))
+         --       (§2-fromMonad
+         --        (.Cat.Category.Monad.toKleisli ℂ
+         --         (.Cat.Category.Monad.toMonoidal ℂ (§2-3.§2.toMonad m))))
+         --       (§2-fromMonad (§2-3.§2.toMonad m))
+         -- Have: PathP
+         --       (λ i →
+         --          §2-3.§2 K.IsMonad.omap
+         --          (K.RawMonad.pure
+         --           (K.Monad.raw
+         --            (funExt (λ m₁ → K.Monad≡ (.Cat.Category.Monad.toKleisliRawEq ℂ m₁))
+         --             i (§2-3.§2.toMonad m)))))
+         --       (§2-fromMonad
+         --        (.Cat.Category.Monad.toKleisli ℂ
+         --         (.Cat.Category.Monad.toMonoidal ℂ (§2-3.§2.toMonad m))))
+         --       (§2-fromMonad (§2-3.§2.toMonad m))
+         ≡⟨ ( cong-d {x = Monoidal→Kleisli ∘ Kleisli→Monoidal} {y = idFun K.Monad} (\ φ → §2-fromMonad (φ (§2-3.§2.toMonad m))) re-ve) ⟩
+       (§2-fromMonad ∘ §2-3.§2.toMonad) m
+         ≡⟨ lemma ⟩
+       m ∎
+        where
+        lemma : (§2-fromMonad ∘ §2-3.§2.toMonad) m ≡ m
+        §2-3.§2.bind (lemma i) = §2-3.§2.bind m
+        §2-3.§2.isMonad (lemma i) = §2-3.§2.isMonad m
+        lemmaz : ∀ m → §2-3.§1.toMonad (§1-fromMonad m) ≡ m
+        M.Monad.raw (lemmaz m i) = M.Monad.raw m
+        M.Monad.isMonad (lemmaz m i) = M.Monad.isMonad m
+
+      backEq : ∀ m → (back ∘ forth) m ≡ m
+      backEq m = begin
+        §1-fromMonad
+        (Kleisli→Monoidal
+        (§2-3.§2.toMonad
+        (§2-fromMonad (Monoidal→Kleisli (§2-3.§1.toMonad m)))))
+          ≡⟨ cong-d (§1-fromMonad ∘ Kleisli→Monoidal) (lemma (Monoidal→Kleisli (§2-3.§1.toMonad m))) ⟩
+        §1-fromMonad
+        ((Kleisli→Monoidal ∘ Monoidal→Kleisli)
+        (§2-3.§1.toMonad m))
+          -- Below is the fully normalized `agda2-goal-and-context`
+          -- with `funExt` made abstract.
+          --
+          -- Goal: PathP (λ _ → §2-3.§1 omap (λ {X} → pure))
+          --       (§1-fromMonad
+          --        (.Cat.Category.Monad.toMonoidal ℂ
+          --         (.Cat.Category.Monad.toKleisli ℂ (§2-3.§1.toMonad m))))
+          --       (§1-fromMonad (§2-3.§1.toMonad m))
+          -- Have: PathP
+          --       (λ i →
+          --          §2-3.§1
+          --          (RawFunctor.omap
+          --           (Functor.raw
+          --            (M.RawMonad.R
+          --             (M.Monad.raw
+          --              (funExt
+          --               (λ m₁ → M.Monad≡ (.Cat.Category.Monad.toMonoidalRawEq ℂ m₁)) i
+          --               (§2-3.§1.toMonad m))))))
+          --          (λ {X} →
+          --             fst
+          --             (M.RawMonad.pureNT
+          --              (M.Monad.raw
+          --               (funExt
+          --                (λ m₁ → M.Monad≡ (.Cat.Category.Monad.toMonoidalRawEq ℂ m₁)) i
+          --                (§2-3.§1.toMonad m))))
+          --             X))
+          --       (§1-fromMonad
+          --        (.Cat.Category.Monad.toMonoidal ℂ
+          --         (.Cat.Category.Monad.toKleisli ℂ (§2-3.§1.toMonad m))))
+          --       (§1-fromMonad (§2-3.§1.toMonad m))
+          ≡⟨ (cong-d (\ φ → §1-fromMonad (φ (§2-3.§1.toMonad m))) ve-re) ⟩
+        §1-fromMonad (§2-3.§1.toMonad m)
+          ≡⟨ lemmaz ⟩
+        m ∎
+       where
+        lemmaz : §1-fromMonad (§2-3.§1.toMonad m) ≡ m
+        §2-3.§1.fmap (lemmaz i) = §2-3.§1.fmap m
+        §2-3.§1.join (lemmaz i) = §2-3.§1.join m
+        §2-3.§1.RisFunctor (lemmaz i) = §2-3.§1.RisFunctor m
+        §2-3.§1.pureN (lemmaz i) = §2-3.§1.pureN m
+        §2-3.§1.joinN (lemmaz i) = §2-3.§1.joinN m
+        §2-3.§1.isMonad (lemmaz i) = §2-3.§1.isMonad m
+        lemma : ∀ m → §2-3.§2.toMonad (§2-fromMonad m) ≡ m
+        K.Monad.raw (lemma m i) = K.Monad.raw m
+        K.Monad.isMonad (lemma m i) = K.Monad.isMonad m
+
+    equiv-2-3 : §2-3.§1 omap pure ≃ §2-3.§2 omap pure
+    equiv-2-3 = fromIsomorphism _ _
+      ( forth , back
+      , funExt backEq , funExt forthEq
+      )

src/Cat/Category/Monoid.agda

@@ -0,0 +1,56 @@
+{-# OPTIONS --allow-unsolved-metas #-}
+module Cat.Category.Monoid where
+
+open import Agda.Primitive
+
+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
+  private
+    ℓ = lsuc (ℓa ⊔ ℓb)
+
+    -- *If* the category of categories existed `_×_` would be equivalent to the
+    -- one brought into scope by doing:
+    --
+    --     open HasProducts (Cat.hasProducts unprovable) using (_×_)
+    --
+    -- Since it doesn't we'll make the following (definitionally equivalent) ad-hoc definition.
+    _×_ : ∀ {ℓa ℓb} → Category ℓa ℓb → Category ℓa ℓb → Category ℓa ℓb
+    ℂ × 𝔻 = Cat.CatProduct.object ℂ 𝔻
+
+  record RawMonoidalCategory (ℂ : Category ℓa ℓb) : Set ℓ where
+    open Category ℂ public hiding (IsAssociative)
+    field
+      empty  : Object
+      -- aka. tensor product, monoidal product.
+      append : Functor (ℂ × ℂ) ℂ
+
+    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 ℂ
+    open RawMonoidalCategory raw public
+
+module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) {monoidal : MonoidalCategory ℂ} {hasProducts : HasProducts ℂ} where
+  private
+    ℓ = ℓa ⊔ ℓb
+
+  open MonoidalCategory monoidal public hiding (mappend)
+  open HasProducts hasProducts
+
+  record MonoidalObject (M : Object) : Set ℓ where
+    field
+      mempty  : Arrow empty M
+      mappend : Arrow (M × M) M

src/Cat/Category/NaturalTransformation.agda

@@ -0,0 +1,147 @@
+-- This module Essentially just provides the data for natural transformations
+--
+-- This includes:
+--
+-- The types:
+--
+-- * Transformation        - a family of functors
+-- * Natural               - naturality condition for transformations
+-- * NaturalTransformation - both of the above
+--
+-- Elements of the above:
+--
+-- * identityTrans   - the identity transformation
+-- * identityNatural - naturality for the above
+-- * identity        - both of the above
+--
+-- Functions for manipulating the above:
+--
+-- * A composition operator.
+{-# OPTIONS --cubical #-}
+open import Cat.Prelude
+
+open import Data.Nat using (_≤′_ ; ≤′-refl ; ≤′-step)
+module Nat = Data.Nat
+
+open import Cat.Category
+open import Cat.Category.Functor
+
+module Cat.Category.NaturalTransformation
+  {ℓc ℓc' ℓd ℓd' : Level}
+  (ℂ : Category ℓc ℓc') (𝔻 : Category ℓd ℓd') where
+
+open Category using (Object)
+private
+  module ℂ = Category ℂ
+  module 𝔻 = Category 𝔻
+
+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 ]
+
+  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
+
+  NaturalTransformation≡ : {α β : NaturalTransformation}
+    → (eq₁ : α .fst ≡ β .fst)
+    → α ≡ β
+  NaturalTransformation≡ eq = lemSig propIsNatural _ _ eq
+
+identityTrans : (F : Functor ℂ 𝔻) → Transformation F F
+identityTrans F C = 𝔻.identity
+
+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
+
+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 ]
+
+  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
+
+    naturalIsProp : (θ : Transformation F G) → isProp (Natural F G θ)
+    naturalIsProp θ θNat θNat' = lem
+      where
+      lem : (λ _ → Natural F G θ) [ (λ f → θNat f) ≡ (λ f → θNat' f) ]
+      lem = λ i f → 𝔻.arrowsAreSets _ _ (θNat f) (θNat' f) i
+
+    naturalIsSet : (θ : Transformation F G) → isSet (Natural F G θ)
+    naturalIsSet θ =
+      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

src/Cat/Category/Pathy.agda

@@ -1,52 +0,0 @@
-{-# OPTIONS --cubical #-}
-
-module Category.Pathy where
-
-open import Cubical.PathPrelude
-
-{-
-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
-
-  pathJprop' : pathJ' _ refl ≡ d
-  pathJprop' i
-    = primComp (λ _ → P x refl) i (λ {j (i = i1) → d}) d
-
-
-module _ {ℓ ℓ'} {A : Set ℓ}
-  (P : (x y : A) → x ≡ y → Set ℓ') (d : (x : A) → P x x refl) where
-  pathJ'' : (x y : A) → (p : x ≡ y) → P x y p
-  pathJ'' _ _ p = transp (λ i →
-    let
-      P' = uncurry P
-      q  = (contrSingl p i)
-    in
-      {!uncurry (uncurry P)!} ) d
--}
-
-module _ {ℓ ℓ'} {A : Set ℓ}
-  (C : (x y : A) → x ≡ y → Set ℓ')
-  (c : (x : A) → C x x refl) where
-
-  =-ind : (x y : A) → (p : x ≡ y) → C x y p
-  =-ind x y p = pathJ (C x) (c x) y p
-
-module _ {ℓ ℓ' : Level} {A : Set ℓ} {P : A → Set ℓ} {x y : A} where
-  private
-    D : (x y : A) → (x ≡ y) → Set ℓ
-    D x y p = P x → P y
-
-    id : {ℓ : Level} → {A : Set ℓ} → A → A
-    id x = x
-
-    d : (x : A) → D x x refl
-    d x = id {A = P x}
-
-  -- the p refers to the third argument
-  liftP : x ≡ y → P x → P y
-  liftP p = =-ind D d x y p
-
-  -- lift' : (u : P x) → (p : x ≡ y) → (x , u) ≡ (y , liftP p u)
-  -- lift' u p = {!!}

src/Cat/Category/Product.agda

@@ -0,0 +1,190 @@
+{-# OPTIONS --cubical --caching #-}
+module Cat.Category.Product where
+
+open import Cat.Prelude as P hiding (_×_ ; fst ; snd)
+open import Cat.Equivalence
+
+open import Cat.Category
+
+module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) 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)
+
+      -- | Arrow product
+      _P[_×_] : ∀ {X} → (π₁ : ℂ [ X , A ]) (π₂ : ℂ [ X , B ])
+        → ℂ [ X , object ]
+      _P[_×_] π₁ π₂ = P.fst (ump π₁ π₂)
+
+    record Product : Set (ℓa ⊔ ℓb) where
+      field
+        raw        : RawProduct
+        isProduct  : IsProduct raw
+
+      open IsProduct isProduct public
+
+  record HasProducts : Set (ℓa ⊔ ℓb) where
+    field
+      product : ∀ (A B : Object) → Product A B
+
+    _×_ : Object → Object → Object
+    A × B = Product.object (product A B)
+
+    -- | Parallel product of arrows
+    --
+    -- 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 using (_P[_×_])
+      open Product (product A B) hiding (_P[_×_]) renaming (fst to fst ; snd to snd)
+      _|×|_ : ℂ [ A , A' ] → ℂ [ B , B' ] → ℂ [ A × B , A' × B' ]
+      f |×| g = product A' B'
+        P[ ℂ [ f ∘ fst ]
+        ×  ℂ [ g ∘ snd ]
+        ]
+
+module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb}
+  (let module ℂ = Category ℂ) {𝒜 ℬ : ℂ.Object} where
+  private
+    module _ (raw : RawProduct ℂ 𝒜 ℬ) where
+      private
+        open Category ℂ hiding (raw)
+        module _ (x y : IsProduct ℂ 𝒜 ℬ raw) where
+          private
+            module x = IsProduct x
+            module y = IsProduct y
+
+          module _ {X : Object} (f : ℂ [ X , 𝒜 ]) (g : ℂ [ X , ℬ ]) where
+            module _ (f×g : Arrow X y.object) where
+              help : isProp (∀{y} → (ℂ [ y.fst ∘ y ] ≡ f) P.× (ℂ [ y.snd ∘ y ] ≡ g) → f×g ≡ y)
+              help = propPiImpl (λ _ → propPi (λ _ → arrowsAreSets _ _))
+
+            res = ∃-unique (x.ump f g) (y.ump f g)
+
+            prodAux : x.ump f g ≡ y.ump f g
+            prodAux = lemSig ((λ f×g → propSig (propSig (arrowsAreSets _ _) λ _ → arrowsAreSets _ _) (λ _ → help f×g))) _ _ res
+
+          propIsProduct' : x ≡ y
+          propIsProduct' i = record { ump = λ f g → prodAux f g i }
+
+      propIsProduct : isProp (IsProduct ℂ 𝒜 ℬ raw)
+      propIsProduct = propIsProduct'
+
+    Product≡ : {x y : Product ℂ 𝒜 ℬ} → (Product.raw x ≡ Product.raw y) → x ≡ y
+    Product≡ {x} {y} p i = record { raw = p i ; isProduct = q i }
+      where
+      q : (λ i → IsProduct ℂ 𝒜 ℬ (p i)) [ Product.isProduct x ≡ Product.isProduct y ]
+      q = lemPropF propIsProduct p
+
+    open P
+    open import Cat.Categories.Span
+
+    open Category (span ℂ 𝒜 ℬ)
+
+    lemma : Terminal ≃ Product ℂ 𝒜 ℬ
+    lemma = fromIsomorphism Terminal (Product ℂ 𝒜 ℬ) (f , g , inv)
+      where
+      f : Terminal → Product ℂ 𝒜 ℬ
+      f ((X , x0 , x1) , uniq) = p
+        where
+        rawP : RawProduct ℂ 𝒜 ℬ
+        rawP = record
+          { object = X
+          ; fst = x0
+          ; snd = x1
+          }
+        -- open RawProduct rawP renaming (fst to x0 ; snd to x1)
+        module _ {Y : ℂ.Object} (p0 : ℂ [ Y , 𝒜 ]) (p1 : ℂ [ Y , ℬ ]) where
+          uy : isContr (Arrow (Y , p0 , p1) (X , x0 , x1))
+          uy = uniq {Y , p0 , p1}
+          open Σ uy renaming (fst to Y→X ; snd to contractible)
+          open Σ Y→X renaming (fst to p0×p1 ; snd to cond)
+          ump : ∃![ f×g ] (ℂ [ x0 ∘ f×g ] ≡ p0 P.× ℂ [ x1 ∘ f×g ] ≡ p1)
+          ump = p0×p1 , cond , λ {f} cond-f → cong fst (contractible (f , cond-f))
+        isP : IsProduct ℂ 𝒜 ℬ rawP
+        isP = record { ump = ump }
+        p : Product ℂ 𝒜 ℬ
+        p = record
+          { raw = rawP
+          ; isProduct = isP
+          }
+      g : Product ℂ 𝒜 ℬ → Terminal
+      g p = 𝒳 , t
+        where
+        open Product p renaming (object to X ; fst to x₀ ; snd to x₁) using ()
+        module p = Product p
+        module isp = IsProduct p.isProduct
+        𝒳 : Object
+        𝒳 = X , x₀ , x₁
+        module _ {𝒴 : Object} where
+          open Σ 𝒴 renaming (fst to Y)
+          open Σ (snd 𝒴) renaming (fst to y₀ ; snd to y₁)
+          ump = p.ump y₀ y₁
+          open Σ ump renaming (fst to f')
+          open Σ (snd ump) renaming (fst to f'-cond)
+          𝒻 : Arrow 𝒴 𝒳
+          𝒻 = f' , f'-cond
+          contractible : (f : Arrow 𝒴 𝒳) → 𝒻 ≡ f
+          contractible ff@(f , f-cond) = res
+            where
+            k : f' ≡ f
+            k = snd (snd ump) f-cond
+            prp : (a : ℂ.Arrow Y X) → isProp
+              ( (ℂ [ x₀ ∘ a ] ≡ y₀)
+              × (ℂ [ x₁ ∘ a ] ≡ y₁)
+              )
+            prp f f0 f1 = Σ≡
+              (ℂ.arrowsAreSets _ _ (fst f0) (fst f1))
+              (ℂ.arrowsAreSets _ _ (snd f0) (snd f1))
+            h :
+              ( λ i
+                → ℂ [ x₀ ∘ k i ] ≡ y₀
+                × ℂ [ x₁ ∘ k i ] ≡ y₁
+              ) [ f'-cond ≡ f-cond ]
+            h = lemPropF prp k
+            res : (f' , f'-cond) ≡ (f , f-cond)
+            res = Σ≡ k h
+        t : IsTerminal 𝒳
+        t {𝒴} = 𝒻 , contractible
+      ve-re : ∀ x → g (f x) ≡ x
+      ve-re x = Propositionality.propTerminal _ _
+      re-ve : ∀ p → f (g p) ≡ p
+      re-ve p = Product≡ e
+        where
+        module p = Product p
+        -- RawProduct does not have eta-equality.
+        e : Product.raw (f (g p)) ≡ Product.raw p
+        RawProduct.object (e i) = p.object
+        RawProduct.fst (e i) = p.fst
+        RawProduct.snd (e i) = p.snd
+      inv : AreInverses f g
+      inv = funExt ve-re , funExt re-ve
+
+  propProduct : isProp (Product ℂ 𝒜 ℬ)
+  propProduct = equivPreservesNType {n = ⟨-1⟩} lemma Propositionality.propTerminal
+
+module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} {A B : Category.Object ℂ} where
+  open Category ℂ
+  private
+    module _ (x y : HasProducts ℂ) where
+      private
+        module x = HasProducts x
+        module y = HasProducts y
+
+      productEq : x.product ≡ y.product
+      productEq = funExt λ A → funExt λ B → propProduct _ _
+
+  propHasProducts : isProp (HasProducts ℂ)
+  propHasProducts x y i = record { product = productEq x y i }

src/Cat/Category/Properties.agda

@@ -1,23 +0,0 @@
-{-# OPTIONS --allow-unsolved-metas #-}
-
-module Cat.Category.Properties where
-
-open import Cat.Category
-open import Cat.Functor
-open import Cat.Categories.Sets
-
-module _ {ℓa ℓa' ℓb ℓb'} where
-  Exponential : Category {ℓa} {ℓa'} → Category {ℓb} {ℓb'} → Category {{!!}} {{!!}}
-  Exponential A B = record
-    { Object = {!!}
-    ; Arrow = {!!}
-    ; 𝟙 = {!!}
-    ; _⊕_ = {!!}
-    ; assoc = {!!}
-    ; ident = {!!}
-    }
-
-_⇑_ = Exponential
-
-yoneda : ∀ {ℓ ℓ'} → {ℂ : Category {ℓ} {ℓ'}} → Functor ℂ (Sets ⇑ (Opposite ℂ))
-yoneda = {!!}

src/Cat/Category/Yoneda.agda

@@ -0,0 +1,84 @@
+{-# OPTIONS --cubical #-}
+
+module Cat.Category.Yoneda where
+
+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.Opposite
+open import Cat.Categories.Sets hiding (presheaf)
+open import Cat.Categories.Fun using (module Fun)
+
+-- There is no (small) category of categories. So we won't use _⇑_ from
+-- `HasExponential`
+--
+--     open HasExponentials (Cat.hasExponentials ℓ unprovable) using (_⇑_)
+--
+-- In stead we'll use an ad-hoc definition -- which is definitionally equivalent
+-- to that other one - even without mentioning the category of categories.
+_⇑_ : {ℓ : Level} → Category ℓ ℓ → Category ℓ ℓ → Category ℓ ℓ
+_⇑_ = Fun.Fun
+
+module _ {ℓ : Level} {ℂ : Category ℓ ℓ} where
+  private
+    𝓢 = Sets ℓ
+    open Fun (opposite ℂ) 𝓢
+
+    module ℂ = Category ℂ
+
+    presheaf : ℂ.Object → Presheaf ℂ
+    presheaf = Cat.Categories.Sets.presheaf ℂ
+
+    module _ {A B : ℂ.Object} (f : ℂ [ A , B ]) where
+      fmap : Transformation (presheaf A) (presheaf B)
+      fmap C x = ℂ [ f ∘ x ]
+
+      fmapNatural : Natural (presheaf A) (presheaf B) fmap
+      fmapNatural g = funExt λ _ → ℂ.isAssociative
+
+      fmapNT : NaturalTransformation (presheaf A) (presheaf B)
+      fmapNT = fmap , fmapNatural
+
+    rawYoneda : RawFunctor ℂ Fun
+    RawFunctor.omap rawYoneda = presheaf
+    RawFunctor.fmap rawYoneda = fmapNT
+
+    open RawFunctor rawYoneda hiding (fmap)
+
+    isIdentity : IsIdentity
+    isIdentity {c} = lemSig prp _ _ eq
+      where
+      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}
+      = lemSig (propIsNatural (presheaf A) (presheaf C)) _ _ eq
+      where
+      T[_∘_]' = T[_∘_] {F = presheaf A} {presheaf B} {presheaf C}
+      eqq : (X : ℂ.Object) → (x : ℂ [ X , A ])
+        → fmap (ℂ [ g ∘ f ]) X x ≡ T[ fmap g ∘ fmap f ]' X x
+      eqq X x = begin
+        fmap (ℂ [ g ∘ f ]) X x ≡⟨⟩
+        ℂ [ ℂ [ g ∘ f ] ∘ x ] ≡⟨ sym ℂ.isAssociative ⟩
+        ℂ [ g ∘ ℂ [ f ∘ x ] ] ≡⟨⟩
+        ℂ [ g ∘ fmap f X x ]  ≡⟨⟩
+        T[ fmap g ∘ fmap f ]' X x ∎
+      eq : fmap (ℂ [ g ∘ f ]) ≡ T[ fmap g ∘ fmap f ]'
+      eq = begin
+        fmap (ℂ [ g ∘ f ])    ≡⟨ funExt (λ X → funExt λ α → eqq X α) ⟩
+        T[ fmap g ∘ fmap f ]' ∎
+
+    instance
+      isFunctor : IsFunctor ℂ Fun rawYoneda
+      IsFunctor.isIdentity     isFunctor = isIdentity
+      IsFunctor.isDistributive isFunctor = isDistributive
+
+  yoneda : Functor ℂ Fun
+  Functor.raw       yoneda = rawYoneda
+  Functor.isFunctor yoneda = isFunctor

src/Cat/Cubical.agda

@@ -1,48 +0,0 @@
-module Cat.Cubical where
-
-open import Agda.Primitive
-open import Data.Bool
-open import Data.Product
-open import Data.Sum
-open import Data.Unit
-open import Data.Empty
-
-open import Cat.Category
-
-module _ {ℓ ℓ' : Level} (Ns : Set ℓ) where
-  -- Σ is the "namespace"
-  ℓo = (lsuc lzero ⊔ ℓ)
-
-  FiniteDecidableSubset : Set ℓ
-  FiniteDecidableSubset = Ns → Bool
-
-  isTrue : Bool → Set
-  isTrue false = ⊥
-  isTrue true = ⊤
-
-  elmsof : (Ns → Bool) → Set ℓ
-  elmsof P = (σ : Ns) → isTrue (P σ)
-
-  𝟚 : Set
-  𝟚 = Bool
-
-  module _ (I J : FiniteDecidableSubset) where
-    private
-      themap : Set {!!}
-      themap = elmsof I → elmsof J ⊎ 𝟚
-      rules : (elmsof I → elmsof J ⊎ 𝟚) → Set
-      rules f = (i j : elmsof I) → {!!}
-
-    Mor = Σ themap rules
-
-  -- The category of names and substitutions
-  ℂ : Category -- {ℓo} {lsuc lzero ⊔ ℓo}
-  ℂ = record
-    -- { Object = FiniteDecidableSubset
-    { Object = Ns → Bool
-    ; Arrow = Mor
-    ; 𝟙 = {!!}
-    ; _⊕_ = {!!}
-    ; assoc = {!!}
-    ; ident = {!!}
-    }

src/Cat/Equivalence.agda

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

src/Cat/Functor.agda

@@ -1,66 +0,0 @@
-module Cat.Functor where
-
-open import Agda.Primitive
-open import Cubical
-open import Function
-
-open import Cat.Category
-
-record Functor {ℓc ℓc' ℓd ℓd'} (C : Category {ℓc} {ℓc'}) (D : Category {ℓd} {ℓd'})
-  : Set (ℓc ⊔ ℓc' ⊔ ℓd ⊔ ℓd') where
-  private
-    open module C = Category C
-    open module D = Category D
-  field
-    func* : C.Object → D.Object
-    func→ : {dom cod : C.Object} → C.Arrow dom cod → D.Arrow (func* dom) (func* cod)
-    ident   : { c : C.Object } → func→ (C.𝟙 {c}) ≡ D.𝟙 {func* c}
-    -- TODO: Avoid use of ugly explicit arguments somehow.
-    -- This guy managed to do it:
-    --    https://github.com/copumpkin/categories/blob/master/Categories/Functor/Core.agda
-    distrib : { c c' c'' : C.Object} {a : C.Arrow c c'} {a' : C.Arrow c' c''}
-      → func→ (a' C.⊕ a) ≡ func→ a' D.⊕ func→ a
-
-module _ {ℓ ℓ' : Level} {A B C : Category {ℓ} {ℓ'}} (F : Functor B C) (G : Functor A B) where
-  private
-    open module F = Functor F
-    open module G = Functor G
-    open module A = Category A
-    open module B = Category B
-    open module C = Category C
-
-    F* = F.func*
-    F→ = F.func→
-    G* = G.func*
-    G→ = G.func→
-    module _ {a0 a1 a2 : A.Object} {α0 : A.Arrow a0 a1} {α1 : A.Arrow a1 a2} where
-
-      dist : (F→ ∘ G→) (α1 A.⊕ α0) ≡ (F→ ∘ G→) α1 C.⊕ (F→ ∘ G→) α0
-      dist = begin
-        (F→ ∘ G→) (α1 A.⊕ α0)         ≡⟨ refl ⟩
-        F→ (G→ (α1 A.⊕ α0))           ≡⟨ cong F→ G.distrib ⟩
-        F→ ((G→ α1) B.⊕ (G→ α0))      ≡⟨ F.distrib ⟩
-        (F→ ∘ G→) α1 C.⊕ (F→ ∘ G→) α0 ∎
-
-  functor-comp : Functor A C
-  functor-comp =
-    record
-      { func* = F* ∘ G*
-      ; func→ = F→ ∘ G→
-      ; ident = begin
-        (F→ ∘ G→) (A.𝟙) ≡⟨ refl ⟩
-        F→ (G→ (A.𝟙))   ≡⟨ cong F→ G.ident ⟩
-        F→ (B.𝟙)        ≡⟨ F.ident ⟩
-        C.𝟙             ∎
-      ; distrib = dist
-      }
-
--- The identity functor
-identity : {ℓ ℓ' : Level} → {C : Category {ℓ} {ℓ'}} → Functor C C
--- Identity = record { F* = λ x → x ; F→ = λ x → x ; ident = refl ; distrib = refl }
-identity = record
-  { func* = λ x → x
-  ; func→ = λ x → x
-  ; ident = refl
-  ; distrib = refl
-  }

src/Cat/Prelude.agda

@@ -0,0 +1,142 @@
+-- | Custom prelude for this module
+module Cat.Prelude where
+
+open import Agda.Primitive public
+-- FIXME Use:
+open import Agda.Builtin.Sigma public
+-- Rather than
+open import Data.Product public
+  renaming (∃! to ∃!≈)
+  using (_×_ ; Σ-syntax ; swap)
+
+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
+-- module.
+open import Cubical.GradLemma
+  using (gradLemma)
+  public
+open import Cubical.NType
+  using (⟨-2⟩ ; ⟨-1⟩ ; ⟨0⟩ ; TLevel ; HasLevel ; isGrpd)
+  public
+open import Cubical.NType.Properties
+  using
+    ( lemPropF ; lemSig ;  lemSigP ; isSetIsProp
+    ; 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 ; sigPresNType) public
+
+module _ (ℓ : Level) where
+  -- FIXME Ask if we can push upstream.
+  -- A redefinition of `Cubical.Universe` with an explicit parameter
+  _-type : TLevel → Set (lsuc ℓ)
+  n -type = Σ (Set ℓ) (HasLevel n)
+
+  hSet : Set (lsuc ℓ)
+  hSet = ⟨0⟩ -type
+
+  hProp : Set (lsuc ℓ)
+  hProp = ⟨-1⟩ -type
+
+-----------------
+-- * Utilities --
+-----------------
+
+-- | 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 (λ 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}
+  (fst≡ : (λ _ → A)            [ fst a ≡ fst b ])
+  (snd≡ : (λ i → B (fst≡ i)) [ snd a ≡ snd b ]) where
+
+  Σ≡ : a ≡ b
+  fst (Σ≡ i) = fst≡ i
+  snd (Σ≡ i) = snd≡ i
+
+import Relation.Binary
+open Relation.Binary public using
+  ( Preorder ; Transitive ; IsEquivalence ; Rel
+  ; Setoid )
+
+equalityIsEquivalence : {ℓ : Level} {A : Set ℓ} → IsEquivalence {A = A} _≡_
+IsEquivalence.refl  equalityIsEquivalence = refl
+IsEquivalence.sym   equalityIsEquivalence = sym
+IsEquivalence.trans equalityIsEquivalence = trans
+
+IsPreorder
+  : {a ℓ : Level} {A : Set a}
+  → (_∼_ : Rel A ℓ) -- The relation.
+  → Set _
+IsPreorder _~_ = Relation.Binary.IsPreorder _≡_ _~_
+
+module _ {ℓ : Level} {A : Set ℓ} {a : A} where
+  -- FIXME rename to `coe-neutral`
+  id-coe : coe refl a ≡ a
+  id-coe = begin
+    coe refl a                 ≡⟨⟩
+    pathJ (λ y x → A) _ A refl ≡⟨ pathJprop {x = a} (λ y x → A) _ ⟩
+    _ ≡⟨ pathJprop {x = a} (λ y x → A) _ ⟩
+    a ∎
+
+module _ {ℓ : Level} {A : Set ℓ} where
+  open import Cubical.NType
+  open import Data.Nat using (_≤′_ ;  ≤′-refl ;  ≤′-step ; zero ; suc)
+  open import Cubical.NType.Properties
+  ntypeCumulative : ∀ {n m} → n ≤′ m → HasLevel ⟨ n ⟩₋₂ A → HasLevel ⟨ m ⟩₋₂ A
+  ntypeCumulative {m}         ≤′-refl      lvl = lvl
+  ntypeCumulative {n} {suc m} (≤′-step le) lvl = HasLevel+1 ⟨ m ⟩₋₂ (ntypeCumulative le lvl)
+
+  grpdPi : {ℓb : Level} {B : A → Set ℓb}
+    → ((a : A) → isGrpd (B a)) → isGrpd ((a : A) → (B a))
+  grpdPi = piPresNType (S (S (S ⟨-2⟩)))
+
+  grpdPiImpl : {ℓb : Level} {B : A → Set ℓb}
+    → ({a : A} → isGrpd (B a)) → isGrpd ({a : A} → (B a))
+  grpdPiImpl {B = B} g = equivPreservesNType {A = Expl} {B = Impl} {n = one} e (grpdPi (λ a → g))
+    where
+    one = (S (S (S ⟨-2⟩)))
+    t : ({a : A} → HasLevel one (B a))
+    t = g
+    Impl = {a : A} → B a
+    Expl = (a : A) → B a
+    expl : Impl → Expl
+    expl f a = f {a}
+    impl : Expl → Impl
+    impl f {a} = f a
+    e : Expl ≃ Impl
+    e = impl , (gradLemma impl expl (λ f → refl) (λ f → refl))
+
+  setGrpd : isSet A → isGrpd A
+  setGrpd = ntypeCumulative
+    {suc (suc zero)} {suc (suc (suc zero))}
+    (≤′-step ≤′-refl)
+
+  propGrpd : isProp A → isGrpd A
+  propGrpd = ntypeCumulative
+    {suc zero} {suc (suc (suc zero))}
+    (≤′-step (≤′-step ≤′-refl))
+
+module _ {ℓa ℓb : Level} {A : Set ℓa} {B : A → Set ℓb} where
+  open TLevel
+  grpdSig : isGrpd A → (∀ a → isGrpd (B a)) → isGrpd (Σ A B)
+  grpdSig = sigPresNType {n = S (S (S ⟨-2⟩))}