diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
index 3b147e787bf..01e7411b8bf 100644
--- a/.github/workflows/ci.yml
+++ b/.github/workflows/ci.yml
@@ -8,7 +8,7 @@ concurrency:
 
 # We set the supported coq-version from here. In order to use this environment variable correctly, look at how they are used in the following jobs.
 env:
-  coq-version-supported: '8.18'
+  coq-version-supported: '8.19'
   ocaml-version: '4.14-flambda'
   deployment-branch: 'gh-pages'
 
@@ -36,7 +36,6 @@ jobs:
       matrix:
         coq-version-dummy:
         - 'supported'
-        - '8.18'
         - 'latest'
         - 'dev'
         os:
@@ -51,7 +50,7 @@ jobs:
       run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV
 
     - name: Checkout repo
-      uses: actions/checkout@v3
+      uses: actions/checkout@v4
     - name: Build HoTT
       uses: coq-community/docker-coq-action@v1
       with:
@@ -82,7 +81,7 @@ jobs:
       if: matrix.coq-version-dummy == 'supported'
       run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV
     - name: Checkout repo
-      uses: actions/checkout@v3
+      uses: actions/checkout@v4
     - name: Build HoTT
       uses: coq-community/docker-coq-action@v1
       with:
@@ -120,7 +119,7 @@ jobs:
       if: matrix.coq-version-dummy == 'supported'
       run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV
     # Checkout branch
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
       with:
         submodules: recursive
     # We use the coq docker so we don't have to build coq
@@ -134,7 +133,7 @@ jobs:
           endGroup
           echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations
           sudo apt-get -o Acquire::Retries=30 update -q
-          sudo apt-get -o Acquire::Retries=30 install python -y --allow-unauthenticated
+          sudo apt-get -o Acquire::Retries=30 install python3 python-is-python3 -y --allow-unauthenticated
           etc/coq-scripts/github/reportify-coq.sh --errors ${{ matrix.extra-gh-reportify }} make TIMED=1 -j2 --output-sync
 
     - name: Revert permissions
@@ -146,7 +145,7 @@ jobs:
       run: tar -cf workspace.tar .
     # We upload build artifacts for use by documentation
     - name: 'Upload Artifact'
-      uses: actions/upload-artifact@v3
+      uses: actions/upload-artifact@v4
       with:
         name: workspace-${{ env.coq-version }}
         path: workspace.tar
@@ -155,7 +154,7 @@ jobs:
   nix:
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
     - uses: cachix/install-nix-action@v20
       with:
         name: coq-hott
@@ -181,11 +180,11 @@ jobs:
     needs: build
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
       with:
         submodules: recursive
     # Download artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: workspace-${{ env.coq-version-supported }}
     # Unpack Tar
@@ -203,11 +202,16 @@ jobs:
         custom_script: |
           opam install -y coq-serapi
           sudo apt-get -o Acquire::Retries=30 update -q
-          sudo apt-get -o Acquire::Retries=30 install python3-pip autoconf -y --allow-unauthenticated
-          python3 -m pip install --user --upgrade pygments dominate beautifulsoup4 docutils==0.17.1
+          sudo apt-get -o Acquire::Retries=30 install python3-pip python3-venv autoconf -y --allow-unauthenticated
           startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions
             sudo chown -R coq:coq .
           endGroup
+          # Create and activate a virtual environment
+          python3 -m venv myenv
+          source myenv/bin/activate
+          # Install the required Python packages in the virtual environment
+          python -m pip install --upgrade pip
+          python -m pip install pygments dominate beautifulsoup4 docutils==0.17.1
           echo "::remove-matcher owner=coq-problem-matcher::" # remove problem matcher installed by Coq docker action, so we don't get duplicate warning annotations
           make alectryon ALECTRYON_EXTRAFLAGS=--traceback
     - name: Revert permissions
@@ -217,7 +221,7 @@ jobs:
     - name: tar alectryon artifact
       run: tar -cf alectryon-html.tar alectryon-html
     - name: upload alectryon artifact
-      uses: actions/upload-artifact@v1
+      uses: actions/upload-artifact@v4
       with:
         name: alectryon-html
         path: alectryon-html.tar
@@ -229,11 +233,11 @@ jobs:
     runs-on: ubuntu-latest
     steps:
     # Checkout branch
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
       with:
         submodules: recursive
     # Download artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: workspace-${{ env.coq-version-supported }}
     # Unpack Tar
@@ -273,7 +277,7 @@ jobs:
           mv HoTT.svg HoTTCore.svg dep-graphs/
 
           ## Install coq-dpdgraph
-          opam install coq-dpdgraph.1.0+8.18 -y
+          opam install coq-dpdgraph.1.0+8.19 -y
 
           # For some reason, we get a stackoverflow. So we are lax
           # with making these.
@@ -300,12 +304,12 @@ jobs:
         tar -cf file-dep-graphs.tar file-dep-graphs
     # We upload the artifacts
     - name: 'Upload Artifact dep-graphs.tar'
-      uses: actions/upload-artifact@v3
+      uses: actions/upload-artifact@v4
       with:
         name: dep-graphs
         path: dep-graphs.tar
     - name: 'Upload Artifact file-dep-graphs.tar'
-      uses: actions/upload-artifact@v3
+      uses: actions/upload-artifact@v4
       with:
         name: file-dep-graphs
         path: file-dep-graphs.tar
@@ -317,11 +321,11 @@ jobs:
     runs-on: ubuntu-latest
     steps:
     # Checkout branch
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
       with:
         submodules: recursive
     # Download artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: workspace-${{ env.coq-version-supported }}
     # Unpack Tar
@@ -348,7 +352,7 @@ jobs:
       run: tar -cf coqdoc-html.tar coqdoc-html
     # Upload coqdoc-html artifact
     - name: 'Upload coqdoc-html Artifact'
-      uses: actions/upload-artifact@v3
+      uses: actions/upload-artifact@v4
       with:
         name: coqdoc-html
         path: coqdoc-html.tar
@@ -360,11 +364,11 @@ jobs:
     runs-on: ubuntu-latest
     steps:
     # Checkout branch
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
       with:
         submodules: recursive
     # Download artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: workspace-${{ env.coq-version-supported }}
     # Unpack Tar
@@ -376,7 +380,7 @@ jobs:
         ocaml_version: ${{ env.ocaml-version }}
         custom_script: |
           sudo apt-get update
-          sudo apt-get install -y time python lua5.1
+          sudo apt-get install -y time python3 python-is-python3 lua5.1
           startGroup "Workaround permission issue" # https://github.com/coq-community/docker-coq-action#permissions
             sudo chown -R coq:coq .
           endGroup
@@ -392,7 +396,7 @@ jobs:
       run: tar -cf timing-html.tar timing-html
     # Upload timing-html artifact
     - name: 'Upload timing-html Artifact'
-      uses: actions/upload-artifact@v3
+      uses: actions/upload-artifact@v4
       with:
         name: timing-html
         path: timing-html.tar
@@ -417,11 +421,11 @@ jobs:
       if: matrix.coq-version-dummy == 'supported'
       run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV
     # Checkout branch
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
       with:
         submodules: recursive
     # Download artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: workspace-${{ env.coq-version }}
     # Unpack Tar
@@ -462,11 +466,11 @@ jobs:
       if: matrix.coq-version-dummy == 'supported'
       run: echo "coq-version=${{ env.coq-version-supported }}" >> $GITHUB_ENV
     # Checkout branch
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
       with:
         submodules: recursive
     # Download artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: workspace-${{ env.coq-version }}
     # Unpack Tar
@@ -508,25 +512,25 @@ jobs:
     runs-on: ubuntu-latest
     steps:
     # Checkout branch
-    - uses: actions/checkout@v3
+    - uses: actions/checkout@v4
     # Download alectryon artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: alectryon-html
     # Download dependency graph artifacts
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: dep-graphs
     # Download file dependency graph artifacts
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: file-dep-graphs
     # Download coqdoc artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: coqdoc-html
     # Download timing artifact
-    - uses: actions/download-artifact@v3
+    - uses: actions/download-artifact@v4
       with:
         name: timing-html
     # Unpack Tar files
diff --git a/.gitignore b/.gitignore
index b74207a870f..ece5a959908 100644
--- a/.gitignore
+++ b/.gitignore
@@ -110,3 +110,6 @@ _CoqProject
 
 # ignore nix profiles
 nix/profiles/
+
+# Ignore the file to bench
+file_to_bench
diff --git a/INSTALL.md b/INSTALL.md
index 4b07a5ef119..f6def5ed597 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -5,6 +5,9 @@ library to use in your own project or to play around with.
 
 - [1. Installation using Coq Platform](#1-installation-using-coq-platform)
 - [2. Installation of HoTT library using opam](#2-installation-of-hott-library-using-opam)
+  - [Released Versions](#released-versions)
+  - [Source Versions](#source-versions)
+  - [Development Versions](#development-versions)
 - [3. Setup for developers (using git)](#3-setup-for-developers-using-git)
   - [3.1. Prequisites (Installing Coq)](#31-prequisites-installing-coq)
     - [3.1.1. Development in OSX and Windows](#311-development-in-osx-and-windows)
@@ -50,8 +53,18 @@ wish to import the entire library you can write:
 From HoTT Require Import HoTT.
 ```
 
+> ### Warning
+>
+> The versions of the HoTT library appearing in the Coq Platform are released
+> twice a year. This means that there is a good chance that the Coq Platform
+> version is lagging behind the latest version of the library. If you wish to
+> use the latest version of the library, you should install it using `opam` as
+> described in the next section.
+
 # 2. Installation of HoTT library using opam
 
+## Released Versions
+
 More advanced users may wish to install the HoTT library via `opam` ([See here
 for details on installing `opam`][3]). You need to add the released coq-archive
 packages to `opam` which can be done as follows:
@@ -66,12 +79,24 @@ library is `coq-hott` inside the coq-archive.
 $ opam install coq-hott
 ```
 
+## Source Versions
+
+After cloning the repository, you can install the library using `opam` by running
+`opam install .` in the root of the repository.
+
+## Development Versions
+
 We also have the current development versions of the library available via
 `opam`. For this however, you will need to add the dev coq-archive packages:
 ```shell
+$ opam repo add coq-core-dev https://coq.inria.fr/opam/core-dev
 $ opam repo add coq-extra-dev https://coq.inria.fr/opam/extra-dev
 ```
 
+This will make `coq.dev` the latest available version of `coq`. You can pin
+`coq` to a stable version by running `opam pin add coq.dev 8.19.1` for example.
+Then install the library with `opam install coq-hott`, as for the released version.
+
 # 3. Setup for developers (using git)
 
 ## 3.1. Prequisites (Installing Coq)
@@ -162,7 +187,8 @@ We recommend the following text editors for the development of `.v` files:
 
  * [Emacs][10] together with [Proof General][11].
  * [CoqIDE][12] part of the [Coq Proof Assistant][13].
- * [Visual Studio Code][14] together with [VSCoq][15].
+ * [Visual Studio Code][14] together with [coq-lsp][15].
+ * For more editors, see the Coq website article on [User Interfaces][19].
 
 ## 4.1. Tags for Emacs
 
@@ -220,7 +246,9 @@ GitHub](https://github.com/HoTT/HoTT).
 [12]: https://coq.inria.fr/refman/practical-tools/coqide.html
 [13]: https://github.com/coq/coq
 [14]: https://code.visualstudio.com/
-[15]: https://github.com/coq-community/vscoq
+[15]: https://github.com/ejgallego/coq-lsp
+
 [16]: https://cygwin.com/install.html
 [17]: https://stackoverflow.com/a/54086635
 [18]: https://git-scm.com/book/en/v2/Getting-Started-Installing-Git
+[19]: https://coq.inria.fr/user-interfaces.html
\ No newline at end of file
diff --git a/README.md b/README.md
index 2e1fb1380f2..a7166404652 100644
--- a/README.md
+++ b/README.md
@@ -47,14 +47,9 @@ your `_CoqProject` file:
 
 For more advanced use such as contribution see [INSTALL.md](/INSTALL.md).
 
-We recommend the following text editors:
-
- * [Emacs][16] together with [Proof General][17].
- * [CoqIDE][18] part of the [Coq Proof Assistant][19].
- * [Visual Studio Code][20] together with [VSCoq][21].
-
-Other methods of developing in `coq` will work as long as the correct arguments
-are passed.
+For **recommended text editors** see [our recommended editors
+list](./INSTALL.md#4-editors). Other methods of developing in `coq` will work as
+long as the correct arguments are passed.
 
 # Contributing
 
@@ -92,11 +87,4 @@ More information can be found in the [Wiki][22].
 [14]: https://github.com/HoTT/HoTT/wiki/Publications-based-on-the-HoTT-library
 [15]: https://github.com/coq/platform/releases
 
-[16]: http://www.gnu.org/software/emacs/
-[17]: http://proofgeneral.inf.ed.ac.uk
-[18]: https://coq.inria.fr/refman/practical-tools/coqide.html
-[19]: https://github.com/coq/coq
-[20]: https://code.visualstudio.com/
-[21]: https://github.com/coq-community/vscoq
-
 [22]: https://github.com/HoTT/HoTT/wiki
\ No newline at end of file
diff --git a/STYLE.md b/STYLE.md
index f1f530c067c..f0b0b3c15a5 100644
--- a/STYLE.md
+++ b/STYLE.md
@@ -5,91 +5,95 @@
 <!-- Ali: VSCode is able to do the TOC using the "Markdown All in One" extension. Section numbering too! -->
 ## Table of Contents 
 
-- [1. Conventions And Style Guide](#1-conventions-and-style-guide)
-  - [1.1. Organization](#11-organization)
-    - [1.1.1. The Core library](#111-the-core-library)
-    - [1.1.2. Non-core files](#112-non-core-files)
-    - [1.1.3. Tests](#113-tests)
-  - [1.2. Naming Conventions](#12-naming-conventions)
-    - [1.2.1. General principles](#121-general-principles)
-    - [1.2.2. Capitalization and spacing](#122-capitalization-and-spacing)
-    - [1.2.3. Suffixes](#123-suffixes)
-    - [1.2.4. Induction and recursion principles](#124-induction-and-recursion-principles)
-    - [1.2.5. Path algebra functions](#125-path-algebra-functions)
-    - [1.2.6. Equivalences](#126-equivalences)
-  - [1.3. Records, Structures, Typeclasses](#13-records-structures-typeclasses)
-    - [1.3.1. Two-component records](#131-two-component-records)
-    - [1.3.2. Typeclasses](#132-typeclasses)
-    - [1.3.3. When to declare instances](#133-when-to-declare-instances)
-    - [1.3.4. Local and Global Instances](#134-local-and-global-instances)
-    - [1.3.5. Using Typeclasses](#135-using-typeclasses)
-    - [1.3.6. Truncation](#136-truncation)
-    - [1.3.7. Coercions and Existing Instances](#137-coercions-and-existing-instances)
-  - [1.4. Axioms](#14-axioms)
-    - [1.4.1. Univalence and function extensionality](#141-univalence-and-function-extensionality)
-    - [1.4.2. Higher inductive types](#142-higher-inductive-types)
-    - [1.4.3. Relationships between axioms](#143-relationships-between-axioms)
-    - [1.4.4. Assuming axioms](#144-assuming-axioms)
-    - [1.4.5. Technical note: Universe-polymorphic axioms](#145-technical-note-universe-polymorphic-axioms)
-  - [1.5. Higher Inductive Types](#15-higher-inductive-types)
-    - [1.5.1. Case analysis on private inductive](#151-case-analysis-on-private-inductive)
-  - [1.6. Universe Polymorphism](#16-universe-polymorphism)
-    - [1.6.1. Displaying universes](#161-displaying-universes)
-    - [1.6.2. Universe annotations](#162-universe-annotations)
-    - [1.6.3. Unexpected universes](#163-unexpected-universes)
-    - [1.6.4. Lifting and lowering](#164-lifting-and-lowering)
-    - [1.6.5. Universes and HITs](#165-universes-and-hits)
-  - [1.7. Transparency and Opacity](#17-transparency-and-opacity)
-  - [1.8. Imports/exports](#18-importsexports)
-  - [1.9. Formatting](#19-formatting)
-    - [1.9.1. Location of commands](#191-location-of-commands)
-    - [1.9.2. Indentation](#192-indentation)
-    - [1.9.3. Line lengths and comments](#193-line-lengths-and-comments)
-    - [1.9.4. Tactic scripts](#194-tactic-scripts)
-    - [1.9.5. Placement of Arguments and types](#195-placement-of-arguments-and-types)
-  - [1.10. Implicit Arguments](#110-implicit-arguments)
-  - [1.11. Coding Hints](#111-coding-hints)
-    - [1.11.1. Notations](#1111-notations)
-    - [1.11.2. Unfolding definitions](#1112-unfolding-definitions)
-    - [1.11.3. Finding theorems](#1113-finding-theorems)
-    - [1.11.4. Simpl nomatch](#1114-simpl-nomatch)
-    - [1.11.5. Available tactics](#1115-available-tactics)
-  - [1.12. Contributing to the library](#112-contributing-to-the-library)
-    - [1.12.1. Fork \& Pull](#1121-fork--pull)
-    - [1.12.2. Approval of pull requests](#1122-approval-of-pull-requests)
-    - [1.12.3. Commit messages](#1123-commit-messages)
-    - [1.12.4. Creating new files](#1124-creating-new-files)
-    - [1.12.5. Travis](#1125-travis)
-    - [1.12.6. Git rebase](#1126-git-rebase)
-    - [1.12.7. Timing scripts](#1127-timing-scripts)
-  - [1.13. Bugs in Coq](#113-bugs-in-coq)
-    - [1.13.1. Reporting bugs](#1131-reporting-bugs)
-    - [1.13.2. Minimizing bugs](#1132-minimizing-bugs)
+- [Conventions And Style Guide](#conventions-and-style-guide)
+  - [1. Organization](#1-organization)
+    - [1.1. The Core library](#11-the-core-library)
+    - [1.2. Non-core files](#12-non-core-files)
+    - [1.3. Tests](#13-tests)
+    - [1.4.  Dependencies](#14--dependencies)
+  - [2. Naming Conventions](#2-naming-conventions)
+    - [2.1. General principles](#21-general-principles)
+    - [2.2. Capitalization and spacing](#22-capitalization-and-spacing)
+    - [2.3. Suffixes](#23-suffixes)
+    - [2.4. Induction and recursion principles](#24-induction-and-recursion-principles)
+    - [2.5. Path algebra functions](#25-path-algebra-functions)
+    - [2.6. Equivalences](#26-equivalences)
+  - [3. Records, Structures, Typeclasses](#3-records-structures-typeclasses)
+    - [3.1. Two-component records](#31-two-component-records)
+    - [3.2. Typeclasses](#32-typeclasses)
+    - [3.3. When to declare instances](#33-when-to-declare-instances)
+    - [3.4. Local and Global Instances](#34-local-and-global-instances)
+    - [3.5. Using Typeclasses](#35-using-typeclasses)
+    - [3.6. Truncation](#36-truncation)
+    - [3.7. Coercions and Existing Instances](#37-coercions-and-existing-instances)
+  - [4. Axioms](#4-axioms)
+    - [4.1. Univalence and function extensionality](#41-univalence-and-function-extensionality)
+    - [4.2. Higher inductive types](#42-higher-inductive-types)
+    - [4.3. Relationships between axioms](#43-relationships-between-axioms)
+    - [4.4. Assuming axioms](#44-assuming-axioms)
+    - [4.5. Technical note: Universe-polymorphic axioms](#45-technical-note-universe-polymorphic-axioms)
+  - [5. Higher Inductive Types](#5-higher-inductive-types)
+    - [5.1. Case analysis on private inductive](#51-case-analysis-on-private-inductive)
+  - [6. Universe Polymorphism](#6-universe-polymorphism)
+    - [6.1. Displaying universes](#61-displaying-universes)
+    - [6.2. Universe annotations](#62-universe-annotations)
+    - [6.3. Unexpected universes](#63-unexpected-universes)
+    - [6.4. Lifting and lowering](#64-lifting-and-lowering)
+    - [6.5. Universes and HITs](#65-universes-and-hits)
+  - [7. Transparency and Opacity](#7-transparency-and-opacity)
+  - [8. Imports/exports](#8-importsexports)
+  - [9. Formatting](#9-formatting)
+    - [9.1. Location of commands](#91-location-of-commands)
+    - [9.2. Indentation](#92-indentation)
+    - [9.3. Line lengths and comments](#93-line-lengths-and-comments)
+    - [9.4. Tactic scripts](#94-tactic-scripts)
+    - [9.5. Placement of Arguments and types](#95-placement-of-arguments-and-types)
+  - [10. Implicit Arguments](#10-implicit-arguments)
+  - [11. Coding Hints](#11-coding-hints)
+    - [11.1. Notations](#111-notations)
+    - [11.2. Unfolding definitions](#112-unfolding-definitions)
+    - [11.3. Finding theorems](#113-finding-theorems)
+    - [11.4. Simpl nomatch](#114-simpl-nomatch)
+    - [11.5. Available tactics](#115-available-tactics)
+  - [12. Contributing to the library](#12-contributing-to-the-library)
+    - [12.1. Fork \& Pull](#121-fork--pull)
+    - [12.2. Approval of pull requests](#122-approval-of-pull-requests)
+    - [12.3. Commit messages](#123-commit-messages)
+    - [12.4. Creating new files](#124-creating-new-files)
+    - [12.5. Travis](#125-travis)
+    - [12.6. Git rebase](#126-git-rebase)
+    - [12.7. Timing scripts](#127-timing-scripts)
+  - [13. Bugs in Coq](#13-bugs-in-coq)
+    - [13.1. Reporting bugs](#131-reporting-bugs)
+    - [13.2. Minimizing bugs](#132-minimizing-bugs)
 
 <!-- END doctoc generated TOC please keep comment here to allow auto update -->
 
-# 1. Conventions And Style Guide #
+# Conventions And Style Guide #
 
-## 1.1. Organization ##
+## 1. Organization ##
 
-### 1.1.1. The Core library ###
+### 1.1. The Core library ###
 
-The Coq files of the HoTT library live in the theories/ directory.
-They are currently in several groups:
+We do not use the Coq standard library, instead working from scratch.
+We do not use the Coq universes `Prop` and `SProp`.
+
+The Coq files of the HoTT library live in the `theories/` directory.
+Many are in subdirectories, and a subdirectory `Foo/` often has a
+corresponding file `Foo.v` that imports everything in the subdirectory.
 
 - `Basics/*`: These files contain basic definitions that underlie
   everything else.  Nothing in the Basics directory should depend on
   anything outside the Basics directory.  The file `Basics` in the
   root imports everything from the directory `Basics/`, so most other
-  files in the library start with `Require Import HoTT.Basics.` (see
-  remarks below on qualified imports).
+  files in the library start with `Require Import HoTT.Basics.` (See
+  remarks below on qualified imports.)
 
 - `Types/*`: This subdirectory contains a file corresponding to each
   basic type former (e.g. sigma-types, pi-types, etc.), which proves
   the "computational" rules for the path-types, transport, functorial
-  action, etc. of that type former.  It also contains `Types/Record`,
-  which provides tactics for proving records equivalent to iterated
-  sigma-types, and `Types/Equiv`, which proves that being an
+  action, etc. of that type former.  It also `Types/Equiv`,
+  which proves that being an
   equivalence is an hprop.  The univalence axiom is introduced, as a
   typeclass (see below) in `Types/Universe`.  Function extensionality
   is introduced in `Basics/Overture` for dependency reasons, but
@@ -99,21 +103,60 @@ They are currently in several groups:
   studied further in their `Types/` file.  Files in `Types/` should
   not depend on anything except `Basics` and other `Types/` files.
 
-- Other files in the root `theories/` directory, such as `Trunc`,
-  `TruncType`, `HProp`, `HSet`, `EquivalenceVarieties`,
-  `FunextVarieties`, `ObjectClassifier`, `ReflectiveSubuniverse`,
-  `Modality`: These contain more advanced facts and theories which may
-  depend on files in `Types/`.  The file `Misc` can be used to help resolve
-  potentially circular dependencies, although it should be avoided
-  whenever possible.  Note that `make clean; make` will produce an
-  error if there is a dependency loop (ordinary `make` may not).
+- There are many other files in the root `theories/` directory,
+  including `TruncType`, `HProp`, `DProp`, `HSet`, `HFiber`,
+  `ObjectClassifier`, `Extensions`, `NullHomotopy`, `PathAny`,
+  `Projective`, `Idempotents`, `Constant`, etc.  These contain more
+  advanced facts and theories which may depend on files in `Types/`.
+  We try to limit the number of files in the top-level folder, and
+  would like to reduce the number.
+
+- `WildCat/*`: Files related to wild categories.  They are used
+  extensively in the library, so we try to minimize the files they
+  depend on.
+
+- `Modalities/*`: Files involving modalities.  The most important files
+  here are `Modalities/ReflectiveSubuniverse` and `Modalities/Modality`.
+
+- `Basics/Trunc`, `TruncType`, `Truncations/*`: Files involving truncations.
+  There are interdependencies between the files in `Truncations/` and some
+  of the `Modalities/*` files.
+
+- `Equiv/*`: Files showing that various definitions of equivalence agree.
+
+- `Pointed/*`: Files related to pointed types.
 
 - `HIT/*`: Files involving higher inductive types.  Each higher
   inductive type is defined in a corresponding file (see conventions
-  on defining HITs, below).  Since the definition of a HIT involves
-  axioms added to the core theory, we isolate them in this directory.
-  In particular, nothing in the root directory should depend on
-  anything in `HIT/` (except, of course, for `HoTT` and `Tests`, below).
+  on defining HITs, below).  These are only lightly used in the rest
+  of the library.  See `Colimits/*` for the HIT that is most commonly used.
+
+- `Diagrams/*`: Files involving graphs and diagrams, used for colimits and
+  limits.
+
+- `Colimits/*`: Files involving colimits.  `Colimits/GraphQuotient`
+  defines graph quotients as a HIT, and other constructions are
+  built from this.
+
+- `Limits/*`: Files involving limits.
+
+- `Cubical/*`: Files involving cubical methods in HoTT.
+
+- `Algebra/*`: Files related to algebra.
+
+- `Analysis/*`: Files related to analysis.
+
+- `Sets/*`: Files related to set theory.
+
+- `Spaces/*`: Files involving various spaces, including `Spaces/Nat/*`,
+  `Spaces/Pos/*`, `Spaces/Int/*`, `Spaces/Finite/*`, `Spaces/List/*`,
+  `Spaces/Circle`, `Spaces/Torus/*`, `Spaces/Universe`, `Spaces/BAut/*`
+  and `Spaces/No/*` (the surreal numbers),
+
+- `Homotopy/*`: Files related to synthetic homotopy theory.
+
+- `Spectra/*`: Files related to spectra in the sense of stable
+  homotopy theory.
 
 - `Tactics, Tactics/*`: some more advanced tactics.
 
@@ -122,26 +165,26 @@ They are currently in several groups:
   the HoTT library, you can say simply `Require Import HoTT` to pull
   in everything (but don't do this for files in the core itself).
 
-- `Tests`: Test suites for the rest of the library.  Currently nearly
-  empty.
+- `PropResizing/*`: Files related to propositional resizing.  Only
+  `PropResizing/PropResizing` is exported by `HoTT`.
 
-- `Utf8`: optional Unicode notations for the basic definitions
-  (we avoid Unicode in the core libary).  Not exported by `HoTT`.
+- `theories/Classes/*`: The math classes library.  While we don't
+  regard this as part of the core library, and don't explicitly
+  export the contents in `HoTT`, some files in the classes library
+  are used by files in the core library.
 
-- `FunextAxiom, UnivalenceAxiom`: You can import these files to assume
-  the axioms globally (in the core, we track them with typeclasses).
-  Two additional related files are `UnivalenceImpliesFunext` and
-  `HIT/IntervalImpliesFunext`; see below.  None of these are exported
-  by `HoTT`.
+### 1.2. Non-core files ###
 
-A dependency graph of all the files in the library can be found on the
-[wiki][wiki]; this may be helpful in avoiding circular dependencies.
-It is updated automatically by Travis (see below) on every push to the
-master branch.
+- `theories/Axioms/`: Contains `FunextAxiom` and `UnivalenceAxiom`:
+  You can import these files to assume the axioms globally (in the
+  core, we track them with typeclasses).
 
-[wiki]: https://github.com/HoTT/HoTT/wiki
+- `theories/Metatheory/*`: Contains `UnivalenceImpliesFunext`,
+  `IntervalImpliesFunext` and other meta-theoretic results.
 
-### 1.1.2. Non-core files ###
+- `theories/Utf8` and `theories/Utf8Minimal`: optional Unicode
+  notations for the basic definitions (we avoid Unicode in the core
+  library).
 
 - `theories/Categories/*`: The categories library, which is not
   considered part of the core (e.g. it uses unicode), but nevertheless
@@ -163,14 +206,23 @@ master branch.
 - `contrib/*`: Other work in progress, or files not judged appropriate
   for the core.
 
-### 1.1.3. Tests ###
+### 1.3. Tests ###
 
-- `tests/*`: Tests of the library.  See the file `tests/README.md` for more
+- `test/*`: Tests of the library.  See the file `test/README.md` for more
   information.
 
-## 1.2. Naming Conventions ##
+### 1.4.  Dependencies ###
 
-### 1.2.1. General principles ###
+A dependency graph of all the files in the library can be found on the
+[wiki][wiki]; this may be helpful in avoiding circular dependencies.
+It is updated automatically by Travis (see below) on every push to the
+master branch.
+
+[wiki]: https://github.com/HoTT/HoTT/wiki
+
+## 2. Naming Conventions ##
+
+### 2.1. General principles ###
 
 In general, the name of a theorem (or definition, or instance, etc.)
 should begin with the property (or structure, or class, or record,
@@ -189,7 +241,7 @@ goal, from outermost to deepest.  For instance, `path_equiv`
 constructs a path in the type `Equiv f g`, while `isequiv_path_equiv`
 shows that `path_equiv` is an equivalence.
 
-### 1.2.2. Capitalization and spacing ###
+### 2.2. Capitalization and spacing ###
 
 Names of types, such as `Unit` and `Equiv` and `IsHProp`, should
 generally be capitalized.  Names of functions and definitions should
@@ -201,7 +253,7 @@ Multiple-word names, especially in lowercase, should generally be
 separated with underscores.  We make an exception for names of types
 beginning with `is`, such as `IsEquiv` and `IsTrunc`.
 
-### 1.2.3. Suffixes ###
+### 2.3. Suffixes ###
 
 A suffix of `D` indicates a dependent version of something ordinarily
 non-dependent.  For instance, `ap` applies to non-dependent functions
@@ -216,7 +268,7 @@ and no obvious concise way to distinguish them, one of them can be
 given a prime suffix, e.g. we have `path_sigma` and `path_sigma'`.
 Do this with caution.
 
-### 1.2.4. Induction and recursion principles ###
+### 2.4. Induction and recursion principles ###
 
 In conformity with the HoTT Book, the induction principle of a
 (perhaps higher) inductive type `thing` (that is, its dependent
@@ -267,7 +319,7 @@ and `equiv_thing_rec`.
 
 [inductionbug]: https://github.com/coq/coq/issues/3745
 
-### 1.2.5. Path algebra functions ###
+### 2.5. Path algebra functions ###
 
 The path algebra functions defined mainly in `Basics/PathGroupoids`
 follow a particular set of naming conventions.  Generally they are
@@ -275,7 +327,7 @@ named according to the head constant of their primary input and the
 pattern of paths appearing therein.  For more details, see the
 comments in `Basics/PathGroupoids`.
 
-### 1.2.6. Equivalences ###
+### 2.6. Equivalences ###
 
 When defining an equivalence, the standard naming procedure is to
 
@@ -288,16 +340,16 @@ using `equiv_foo` unless you really do need an `Equiv` object, rather
 than a function which happens to be an equivalence.
 
 
-## 1.3. Records, Structures, Typeclasses ##
+## 3. Records, Structures, Typeclasses ##
 
 We use Coq Records when appropriate for important definitions.  For
-instance, contractibility (`Contr`) and equivalences (`Equiv`) are
+instance, being an equivalence (`IsEquiv`) and equivalences (`Equiv`) are
 both Record types (in fact, the former is a typeclass).  The file
-`Types/Record` contains some tactics for proving semiautomatically
+`Basics/Tactics` contains a tactic `issig` for proving semiautomatically
 that record types are equivalent to the corresponding sigma-types, so
 that the relevant general theorems can be applied to them.
 
-### 1.3.1. Two-component records ###
+### 3.1. Two-component records ###
 
 Sometimes a two-component record is better defined as a sigma-type,
 especially if it is a "subset type" whose second component is an
@@ -307,24 +359,22 @@ names for its constructor and its fields, and we can apply theorems in
 
 TODO: Decide about `hProp` and `hSet` and `TruncType` (issue [#514](https://github.com/HoTT/HoTT/issues/514)).
 
-### 1.3.2. Typeclasses ###
+### 3.2. Typeclasses ###
 
 We are using typeclasses in preference to canonical structures.
 Typeclasses are particularly convenient for h-properties of objects.
 Here are some of the typeclasses we are using:
 
 - equivalences: `IsEquiv`
-- truncation levels: `Contr`, `IsTrunc`
+- truncation levels: `IsTrunc` (a notation for `IsTrunc_internal`)
 - axioms (see below): `Funext`, `Univalence`
 - subuniverses: `In`, `Replete`, `MapIn`, `IsConnected`, `IsConnMap`
 
 `IsHSet`, `IsHProp`, and `Contr` are notations for `IsTrunc 0`,
-`IsTrunc -1`, and `IsTrunc -2` respectively.  Since `IsTrunc` is
-defined recursively with contractibility as the base case, there is a
-bit of magic involving a definition called `Contr_internal`; see the
-comments in `Overture.v`.
+`IsTrunc -1`, and `IsTrunc -2` respectively.  See the comments in
+`Overture.v` for more details.
 
-### 1.3.3. When to declare instances ###
+### 3.3. When to declare instances ###
 
 When constructing terms in a typeclass record such as `IsEquiv`, `Contr`,
 or `IsTrunc`, one has the choice to declare it as an `Instance`, in which
@@ -364,7 +414,7 @@ than an `Instance` and then say
 Hint Immediate foo : typeclass_instances.
 ```
 
-### 1.3.4. Local and Global Instances ###
+### 3.4. Local and Global Instances ###
 
 When declaring an `Instance` you should *always* use either the
 `Local` or the `Global` keyword.  The former makes the instance local
@@ -376,7 +426,7 @@ If you write `Instance` without `Local` or `Global`, Coq will
 sometimes make it local and sometimes global, so to avoid confusion it
 is better to always specify explicitly which you intend.
 
-### 1.3.5. Using Typeclasses ###
+### 3.5. Using Typeclasses ###
 
 Try to avoid ever giving a name to variables inhabiting typeclasses.
 When introducing such a variable, you can write `intros ?` to put it
@@ -391,7 +441,7 @@ familiar with.)
 
 Unfortunately, it is not currently possible to write `_` in a
 `refine`d term for an inhabitant of a typeclass and have Coq generate
-a subgoal if it can't find an instance; Coq will die if it can't
+a subgoal if it can't find an instance; Coq will fail if it can't
 resolve a typeclass variable from the context.  You have to `assert`
 or `pose` such an inhabitant first, or give an explicit term for it.
 
@@ -400,18 +450,26 @@ Note that when you don't give a name to a variable, Coq often names it
 avoid using `H` for your own explicitly named variables, since if you
 do and later on someone introduces a new unnamed hypothesis that Coq
 names `H`, your name will result in a conflict.  Conversely, we
-sometimes give a hypothesis a name that won't be used, to pre-empt
+sometimes give a hypothesis a name that won't be used, to preempt
 such conflicts, such as `{ua : Univalence}` or `{fs : Funext}`.
 
-One gotcha about typeclass arguments is that they cannot be inferred automatically when preceeded by non-implicit arguments.  So for instance if we write
+One gotcha about typeclass arguments is that they cannot be inferred
+automatically when preceded by non-implicit arguments.  So for instance
+if we write
 
 ```coq
 Definition foo (A : Type) `{Funext}
 ```
 
-then the `Funext` argument will not generally be inferrable.  Thus, typeclass arguments should generally come first if possible.  In addition, note that when section variables are generalized at the close of a section, they appear first.  Thus, if anything in a section requires `Funext` or `Univalence`, those hypotheses should go in the `Context` at the top of the section in order that they'll come first in the eventual argument lists.
+then the `Funext` argument will not generally be inferable.  Thus,
+typeclass arguments should generally come first if possible.  In
+addition, note that when section variables are generalized at the
+close of a section, they appear first.  Thus, if anything in a section
+requires `Funext` or `Univalence`, those hypotheses should go in the
+`Context` at the top of the section in order that they'll come first
+in the eventual argument lists.
 
-### 1.3.6. Truncation ###
+### 3.6. Truncation ###
 
 The conventions for the typeclass `IsTrunc` are:
 
@@ -421,14 +479,16 @@ The conventions for the typeclass `IsTrunc` are:
   `IsTrunc n (A * B)` gets transformed to `IsTrunc n A` and `IsTrunc n B`,
   as a goal.
 * Due to the desire to use `IsTrunc` rather than `Contr`, we have
-  `Contr` as a notation for `IsTrunc minus_two`, which bottoms out at
-  `Contr_internal`, which is its own typeclass.  Due to a
+  `Contr` as a notation for `IsTrunc minus_two`.
+<!-- I don't think this applies anymore:
+   Due to a
   [bug in coq](https://coq.inria.fr/bugs/show_bug.cgi?id=3100), we
   need to iota-expand some explicit instances of `Contr`, such as
   `Instance foo : Contr bar := let x := {| center := ... |} in x.`
   rather than `Instance foo : Contr bar := { center := ... }.`
+-->
 
-### 1.3.7. Coercions and Existing Instances ###
+### 3.7. Coercions and Existing Instances ###
 
 A "coercion" from `A` to `B` is a function that Coq will insert
 silently if given an `A` when it expects a `B`, and which it doesn't
@@ -438,22 +498,18 @@ without needing to manually apply the projection `equiv_fun`.
 Coercions can make code easier to read and write, but when used
 carelessly they can have the opposite effect.
 
-When defining a record, Coq allows you to declare a field as a
-coercion by writing its type with `:>` instead of `:`.  Please do
-_not_ do this in the core: instead, give an explicit `Coercion`
-declaration after defining the record.  There are two reasons for
-this.  Firstly, the syntax `:>` is very short and easy to miss when
-reading the code, while coercions are important to be aware of.
-Secondly, it is potentially confusing because the same syntax `:>`
-when defining a typeclass (i.e. a `Class` instead of a `Record`) has a
+When defining a `Record`, Coq allows you to declare a field as a
+coercion by writing its type with `:>` instead of `:`.
+When defining a `Class`, the `:>` notation  has a
 different meaning: it declares a field as an `Existing Instance`.
-Please do not use it in that case either; declare your `Existing
-Instance`s explicitly as well.
 
+(In addition, the `:>` notation is used when needed for path types
+to indicate the type in which the paths are taken:  `x = y :> A`
+for `x, y : A`.)
 
-## 1.4. Axioms ##
+## 4. Axioms ##
 
-### 1.4.1. Univalence and function extensionality ###
+### 4.1. Univalence and function extensionality ###
 
 The "axioms" of `Univalence` and `Funext` (function extensionality)
 are typeclasses rather than Coq `Axiom`s.  (But see the technical note
@@ -482,26 +538,25 @@ Section UsesUnivalence.
 
 Now everything defined and proven in this section can use univalence
 without saying so explicitly, and at the end of the section it will be
-implicitly generalized if necessary.  The backquote syntax
+implicitly generalized if necessary.  (Results that don't use univalence
+won't get an univalence argument.)  The backquote syntax
 ``{Univalence}` allows us to avoid giving a name to the hypothesis.
 (Backquote syntax is also used for implicit generalization of
 variables, but that is not needed for univalence and funext.)
 
-### 1.4.2. Higher inductive types ###
+### 4.2. Higher inductive types ###
 
 Every higher inductive type technically assumes some `Axioms`.  These
-axioms are asserted globally by the corresponding `HIT/` file, since
-there's not much point to assuming a HIT without the axioms that make
-it work.
+axioms are asserted globally by the corresponding `HIT/` file or
+`Colimits/GraphQuotient`, since there's not much point to assuming a
+HIT without the axioms that make it work.
 
-### 1.4.3. Relationships between axioms ###
+### 4.3. Relationships between axioms ###
 
 The file `UnivalenceImpliesFunext` shows, as its name implies, that
-univalence implies funext.  Thus, if you import this file, then
-whenever you have assumed univalence, then funext is also true
-automatically and doesn't need to be assumed separately.  (This is
-usually good, to simplify your hypotheses, unless you are working in
-part of the core that `UnivalenceImpliesFunext` depends on.)
+univalence implies funext.  However, this file is not needed in
+practice, since in `Types/Universe` we assert axiomatically that
+univalence implies funext.
 
 Similarly, the file `HIT/IntervalImpliesFunext` proves funext from the
 interval type assumed in `HIT/Interval`, so if you import this file
@@ -511,7 +566,7 @@ always possible to prove funext by hand, but by importing
 `HIT/Interval` without `HIT/IntervalImpliesFunext` you can still use
 the interval in some places and track moral uses of funext elsewhere.
 
-### 1.4.4. Assuming axioms ###
+### 4.4. Assuming axioms ###
 
 When working in a derived development using the HoTT library, you may
 import the files `FunextAxiom` and/or `UnivalenceAxiom` to assume
@@ -523,7 +578,7 @@ imports them both, it ends up with two different witnesses for
 be judgmentally equal might fail to be so because they use different
 witnesses.
 
-### 1.4.5. Technical note: Universe-polymorphic axioms ###
+### 4.5. Technical note: Universe-polymorphic axioms ###
 
 In order for the "axioms" univalence and funext to be usable at
 different universe levels, the types `Univalence` and `Funext` do not
@@ -546,12 +601,14 @@ When introducing further axioms, please use this same naming
 convention.  For another example, see `ExcludedMiddle.v`.
 
 
-## 1.5. Higher Inductive Types ##
+## 5. Higher Inductive Types ##
 
-At present, higher inductive types are restricted to the `HIT/`
-directory, and are all defined using [Dan Licata's "private inductive
-types" hack][hit-hack] which was [implemented in Coq](https://coq.inria.fr/files/coq5_submission_3.pdf) by Yves Bertot.
-This means the procedure for defining a HIT is:
+Most higher inductive types are defined in the `HIT/`
+directory, but `Colimits/GraphQuotient` also uses a HIT.
+All are defined using [Dan Licata's "private inductive
+types" hack][hit-hack] which was
+[implemented in Coq](https://coq.inria.fr/files/coq5_submission_3.pdf)
+by Yves Bertot.  This means the procedure for defining a HIT is:
 
 1. Wrap the entire definition in a module, which you will usually want
    to export to the rest of the file containing the definition.
@@ -586,22 +643,25 @@ This means the procedure for defining a HIT is:
 
 Look at some of the existing files in `HIT/*` for examples.
 
+Going forward, we try to use `Colimits/GraphQuotient` to define further
+higher inductive types.
+
 [hit-hack]: http://homotopytypetheory.org/2011/04/23/running-circles-around-in-your-proof-assistant/
 
-### 1.5.1. Case analysis on private inductive ###
+### 5.1. Case analysis on private inductive ###
 
 You may get this error at `Qed`/`Defined` if unification unfolded
 the induction principle and used its value to produce the proof term.
 
-To fix this, you need to identify which tactic produced the problematic term, then
-either avoid unification by annotating more (e.g. `apply (@foo bla)`
+To fix this, you need to identify which tactic produced the problematic term,
+then either avoid unification by annotating more (e.g. `apply (@foo bla)`
 instead of `apply foo`), or guide unification by manipulating the goal
 (e.g. using `rewrite` with the lemma witnessing the computation rule of
 the inductive principle) or making related definitions opaque.
 
-## 1.6. Universe Polymorphism ##
+## 6. Universe Polymorphism ##
 
-We have Coq's new "universe polymorphism" feature turned on throughout
+We have Coq's "universe polymorphism" feature turned on throughout
 the library.  Thus, all definitions are universe polymorphic by
 default, i.e. they can be applied to types that live in any universe
 level.
@@ -613,7 +673,7 @@ is not found which is "obviously" present, or a term doesn't have a
 type that it "clearly" does (or, of course, if it complains about a
 universe inconsistency), then a universe problem may be the culprit.
 
-### 1.6.1. Displaying universes ###
+### 6.1. Displaying universes ###
 
 If you suspect a universe problem, usually the first thing to do is to
 turn on the display of universes with the command `Set Printing
@@ -652,7 +712,7 @@ display information about `foo` as a _definition_, while `Check`
 treats its argument as a _term_ to be typechecked, and Coq is willing
 to collapse some universes during typechecking.
 
-### 1.6.2. Universe annotations ###
+### 6.2. Universe annotations ###
 
 You can exert a certain degree of control over universe polymorphism
 by using explicit universe annotations, which use the same syntax as
@@ -674,21 +734,18 @@ define `foo` using a universe `i`, and then define `bar` which uses
 coincide with `i` in `foo`, you must annotate the occurrences of `foo`
 in `bar` appropriately.
 
-(It is possible to explicitly declare and name universes globally with
-the `Universe` command, but we are not using that in the HoTT
-library.  Universes declared with `Universe` will be discharged on each 
-section definition independently.)
-
-Unfortunately it is not currently possible to declare the universe
-parameters of a definition; Coq simply decides after you make a
-definition how many universe parameters it ends up with (and what the
-constraints on them are).  The best we can do is to document the
-result.  A sort of "checked documentation" is possible by writing
-`Check foo@{a b c}.` after the definition; this will fail with an
-`Error` unless `foo` takes exactly three universe parameters.  In
-general `Check` is discouraged outside of test suites, so use this
-sparingly; currently it is mainly restricted to the fields of module
-types (see `ReflectiveSubuniverse` for details).
+It is also possible to explicitly declare and name universes globally
+with the `Universe` command, usually within a section.  Universes
+declared with `Universe` will be discharged on each section definition
+independently.
+
+The universe variables of a definition can be declared and their
+constraints can be chosen by hand.  This is good practice for
+delicate situations, as it serves to both document the expected
+constraints and to cause an error if a future change causes the
+universe variables or constraints to change.  We also use `Check`
+commands, mostly in `test/*`, to verify that universe variables
+before as expected.
 
 There are several uses for universe annotations.  One is to force a
 definition to have fewer universe parameters than it would otherwise.
@@ -721,7 +778,14 @@ situations, Coq seems to make a default guess that doesn't work
 then complains without trying anything else; an annotation can point
 it in the right direction.
 
-### 1.6.3. Unexpected universes ###
+In Coq, the bottom universe is denoted `Set`, but this does not
+mean that its elements 0-truncated.  In `Basics/Overture`, we
+define a notation `Type0` for this universe.
+
+Coq also has universes `Prop` and `SProp` which we do not use in
+the library.
+
+### 6.3. Unexpected universes ###
 
 If you ever need to pay close attention to universes, it is useful to
 know that there are several ways in which extra universe parameters
@@ -736,7 +800,7 @@ argument (e.g. a type or a type family), the resulting definition will
 pick up an extra universe parameter that's strictly larger than the
 argument in question.  One way to avoid this is to instead use a
 `Fixpoint` definition, or the tactic `fix`, along with `destruct`.
-There is a tactic `simple_induction` defined in `Overture` whose
+There is a tactic `simple_induction` defined in `Basics/Tactics` whose
 interface is almost the same as `induction` but does this internally,
 although it only works for induction over `nat` and `trunc_index`.
 
@@ -762,7 +826,7 @@ which will remain in the definition as a phantom type:
 `fresh |= forall n : nat, foo n`. Annotating the binder will get rid of it.
 See also [bug #4868](https://coq.inria.fr/bugs/show_bug.cgi?id=4868).
 
-### 1.6.4. Lifting and lowering ###
+### 6.4. Lifting and lowering ###
 
 The file `Basics/UniverseLevel` contains an operation `Lift` which
 lifts a type from one universe to a larger one, with maps `lift` and
@@ -773,7 +837,7 @@ collapse of two universes that ought to remain distinct.  There are
 primed versions `Lift'`, `lift'`, and `lower'` which allow the two
 universe levels to possibly be the same.
 
-### 1.6.5. Universes and HITs ###
+### 6.5. Universes and HITs ###
 
 Another use for universe annotations is to force HITs to live in the
 correct universe.  Coq assigns a universe level to an inductive type
@@ -788,7 +852,7 @@ the few cases when it arises, it should be solvable with universe
 annotations, but we have not yet implemented such a fix; see bug #565.
 
 
-## 1.7. Transparency and Opacity ##
+## 7. Transparency and Opacity ##
 
 If the value of something being defined matters, then you must either
 give an explicit term defining it, or construct it with tactics and
@@ -806,7 +870,7 @@ you doubt this, try making some of it opaque and you will find that
 the "higher coherences" such as `pentagon` and `eckmann_hilton` will
 fail to typecheck.
 
-In general, it is okay to contruct something transparent using
+In general, it is okay to construct something transparent using
 tactics; it's often a matter of aesthetics whether an explicit proof
 term or a tactic proof is more readable or elegant, and personal
 aesthetics may differ.  Consider, for example, the explicit proof term
@@ -831,18 +895,21 @@ constructed using smaller pieces like `ap` and `concat` which we can
 understand.
 
 Here are some acceptable tactics to use in transparent definitions
-(this is probably not an exhaustive list):
+(this is not an exhaustive list):
 
 - `intros`, `revert`, `generalize`, `generalize dependent`
 - `pose`, `assert`, `set`, `cut`
 - `transparent assert` (see below)
-- `fold`, `unfold`, `simpl`, `cbn`, `hnf`
+- `fold`, `unfold`, `simpl`, `cbn`, `hnf`, `change`
 - `case`, `elim`, `destruct`, `induction`
-- `apply`, `eapply`, `assumption`, `eassumption`, `refine`, `exact`
+- `apply`, `eapply`, `assumption`, `eassumption`, `exact`
+- `refine`, `nrefine`, `srefine`, `snrefine` (see below for the last three)
+- `rapply`, `nrapply`, `srapply`, `snrapply` (see below)
+- `lhs`, `lhs_V`, `rhs`, `rhs_V`
 - `reflexivity`, `symmetry`, `transitivity`, `etransitivity`
 - `by`, `done`
 
-Conversely, if you want to use `rewrite`, that is fine, but you should
+Conversely, if you want to use `rewrite`, that is fine, but you might
 then make the thing you are defining opaque.  If it turns out later
 that you need it to be transparent, then you should go back and prove
 it without using `rewrite`.
@@ -855,8 +922,8 @@ necessary.
 
 Note that it *is* acceptable for the definition of a transparent
 theorem to invoke other theorems which are opaque.  For instance,
-the `isequiv_adjointify` lemma itself is actually transparent, but it invokes
-an opaque sublemma that computes the triangle identity (using
+the `isequiv_adjointify` lemma itself is actually transparent, but it
+invokes an opaque sublemma that computes the triangle identity (using
 `rewrite`).  Making the main lemma transparent is necessary so that
 the other parts of an equivalence -- the inverse function and
 homotopies -- will compute.  Thus, a transparent definition will not
@@ -873,15 +940,20 @@ proof term (at least if the proof is ended with `Defined.`).
 For a transparent subterm, use `refine` or `transparent assert` (the
 latter defined in `Basics/Overture`; see "Available tactics", below).
 
-## 1.8. Imports/exports ##
+## 8. Imports/exports ##
 
-Most `Require` commands should be just `Require Import`: imports should not be re-exported, by default.
+Most `Require` commands should be just `Require Import` rather than
+`Require Export`: imports should not be re-exported, by default.
 
-However, if you can't imagine making practical use of file `Foo` without file `Bar`, then `Bar` may export `Foo` via `Require Export Foo`. For instance, `Modality` exports `ReflectiveSubuniverse` because so many of the theorems about modalities are actually theorems about reflective subuniverses.
+However, if you can't imagine making practical use of file `Foo`
+without file `Bar`, then `Bar` may export `Foo` via `Require Export
+Foo`. For instance, `Modality` exports `ReflectiveSubuniverse` because
+so many of the theorems about modalities are actually theorems about
+reflective subuniverses.
 
-## 1.9. Formatting ##
+## 9. Formatting ##
 
-### 1.9.1. Location of commands
+### 9.1. Location of commands
 
 All `Require` commands should be placed at the top of a file.
 Ideally, they should be grouped onto lines according to the rough
@@ -894,7 +966,7 @@ in that case they should usually come at the beginning of the Section.
 The assumptions of a section, such as `Variable` and `Context`, should
 also generally come at the beginning of that section.
 
-### 1.9.2. Indentation
+### 9.2. Indentation
 
 In general, the bodies of sections and modules should be indented, two
 spaces per nested section or module.  This is the default behavior of
@@ -906,15 +978,16 @@ excessive churn in the diff.  If you wish, you can submit a separate
 pull request or commit for the re-indentation, labeled as "only
 whitespace changes" so that no one bothers reading the diff carefully.
 
-### 1.9.3. Line lengths and comments
+### 9.3. Line lengths and comments
 
 Lines of code should be of limited width; try to restrict yourself to
 not much more than 70 characters.  Remember that when Coq code is
 often edited in split-screen so that the screen width is cut in half,
 and that not everyone's screen is as wide as yours.
 
-[coqdoc](https://coq.inria.fr/refman/using/tools/coqdoc.html) is used to produce
-a browsable [view of the library](https://hott.github.io/Coq-HoTT/coqdoc-html/toc.html).
+[coqdoc](https://coq.inria.fr/refman/using/tools/coqdoc.html) is used
+to produce a browsable
+[view of the library](https://hott.github.io/Coq-HoTT/coqdoc-html/toc.html).
 coqdoc treats comments specially, so comments should follow the
 conventions described on the coqdoc page.  The most important ones are
 that Coq expressions within comments are surrounded by square brackets,
@@ -954,7 +1027,7 @@ Stylish plugin, you can make them wrap by adding the following style:
 This messes up the line-numbering, though, you'll have to turn it
 off in order to link to or comment on a particular line.
 
-### 1.9.4. Tactic scripts ###
+### 9.4. Tactic scripts ###
 
 When writing tactic scripts, `Proof.` and `Defined.` should be given
 as individual lines, and the tactic code should be indented.  Within
@@ -970,7 +1043,7 @@ constructs such as bullets and braces to clarify the structure.  See
 the section of the Coq Reference Manual entitled "Navigation in the
 proof tree".
 
-### 1.9.5. Placement of Arguments and types ###
+### 9.5. Placement of Arguments and types ###
 
 If the entire type of a theorem or definition does not fit on one
 line, then it is better to put the result type (the part after the
@@ -1007,7 +1080,7 @@ Of course, if the term is longer than one line, it should be broken
 across lines, with later lines indented further.
 
 
-## 1.10. Implicit Arguments ##
+## 10. Implicit Arguments ##
 
 Do not use `Set Implicit Arguments` in the core.  It makes it
 difficult for a newcomer to read the code; use braces `{...}` to
@@ -1015,15 +1088,15 @@ explicitly mark which arguments are implicit.  If necessary, you can
 use the `Arguments` command to adjust implicitness of arguments after
 a function is defined, but braces are preferable when possible.
 
-Warning: if you want to use `Arguments` to make *all* the arguments of
+If you want to use `Arguments` to make *all* the arguments of
 a function explicit, the obvious-looking syntax `Arguments foo a b`
 does not work: you have to write `Arguments foo : clear implicits`
 instead.
 
 
-## 1.11. Coding Hints ##
+## 11. Coding Hints ##
 
-### 1.11.1. Notations ###
+### 11.1. Notations ###
 
 The operation `compose`, notation `g o f`, is simply a notation for
 `fun x => g (f x)` rather than a defined constant.  We define `compose
@@ -1036,7 +1109,7 @@ goals which are really different.  We consider it poor style to use
 `compose` as a partially applied constant, such as `compose g`; we
 take the point of view that `fun f => g o f` is more readable anyway.
 
-### 1.11.2. Unfolding definitions ###
+### 11.2. Unfolding definitions ###
 
 When a definition has to be unfolded repeatedly in the middle of
 proofs, you can say `Local Arguments name / .`, which tells `simpl`
@@ -1052,7 +1125,7 @@ the problem lies is to turn on printing of all implicit arguments with
 `Set Printing All`; another is to use `Set Debug Tactic Unification`
 and inspect the output to see where `rewrite` is failing to unify.
 
-### 1.11.3. Finding theorems ###
+### 11.3. Finding theorems ###
 
 The naming conventions mentioned above often help to guess the name of
 a theorem.  However, it still may happen that you expect that a
@@ -1061,24 +1134,24 @@ to finding it is to guess what file it should live in and look there;
 for instance, theorems about sigma-types are often in `Types/Sigma.v`,
 and so on.
 
-Another approach is to use Coq's command `SearchAbout` to display all
-the theorems that relate to a particular definition.  This has the
-[disadvantage](https://coq.inria.fr/bugs/show_bug.cgi?id=3904) that it
-doesn't "look through" definitions and notations.  For instance,
-`IsHProp` is a `Notation` for `IsTrunc -1`, but `SearchAbout IsHProp`
-won't show you theorems about `IsTrunc`.  So if you can't find
-something at first using `SearchAbout`, think about ways that your
-desired theorem might be generalized and search for those instead.
+Another approach is to use Coq's command `Search` to display all the
+theorems that relate to a particular definition.  For example, `Search
+(IsHProp ?A)` will show all results in which the expression `IsHProp
+A` appears for some `A`, and `Search "ishprop"` will show all results
+having "ishprop" in the name.  However, some results about `HProp` are
+true for any truncation level, so you may want to expand your search
+to include `IsTrunc`.  In general, if you can't find something at
+first using `Search`, think about ways that your desired theorem might
+be generalized and search for those instead.
 
 Generalizing from a particular truncation level (like `IsHProp`) to
 all truncation levels is a good example.  Another one that it's
 important to be aware of is a generalization from truncation
 (`IsTrunc` and `Trunc`) to all reflective subuniverses or modalities;
 many many theorems about truncation are actually proven more generally
-in the latter situations.  (To obtain those theorems for the special
-case of truncation, you'll generally need to `Import TrM`.)
+in the latter situations.
 
-### 1.11.4. Simpl nomatch ###
+### 11.4. Simpl nomatch ###
 
 If a theorem or definition is defined by `destruct` or `match` (as
 many operations on paths are), and if its value needs to be reasoned
@@ -1087,35 +1160,16 @@ about in tactic proofs, then it is helpful to declare its arguments as
 related tactics never to simplify it if doing so would result in a
 `match` that doesn't reduce, which is usually what you want.
 
-### 1.11.5. Available tactics ###
+### 11.5. Available tactics ###
 
 Here are some tactics defined in the core that you may find useful.
 They are described more fully, usually with examples, in the files
 where they are defined.
 
-- `transparent assert`: Defined in `Basics/Overture`, this tactic is
-  like `assert` but produces a transparent subterm rather than an
-  opaque one.  Due to restrictions of tactic notations, you have to
-  write `transparent assert (foo : (bar baz))` rather than
-  `transparent assert (foo : bar baz)`.
-
-- `simpl rewrite`: Defined in `Tactics`, this tactic applies `simpl`
-  to the type of a lemma, and to the goal, before rewriting the goal
-  with the lemma.  In particular, this is useful for rewriting with
-  lemmas containing definitions like `compose` that appear unfolded in
-  the goal: if the operation has `Arguments ... / .` as above then
-  `simpl` will unfold it.
-
-- `binder apply`: Defined in `Tactics/BinderApply`, this tactic
-  applies a lemma inside of a lambda abstraction, in the goal or in a
-  hypothesis.
-
-- `issig`: Defined in `Types/Record`, this tactic proves automatically
-  that a record type is equivalent to a nested sigma-type.
-
 - `nrefine`, `srefine`, `snrefine`:
   Defined in `Basics/Overture`, these are shorthands for
   `notypeclasses refine`, `simple refine`, and `simple notypeclasses refine`.
+  It's good to avoid typeclass search if it isn't needed.
 
 - `rapply`, `nrapply`, `srapply`, `snrapply`:
   Defined in `Basics/Overture`, these tactics use `refine`,
@@ -1127,25 +1181,59 @@ where they are defined.
  
   Here are some tips:
   - If `apply` fails with a unification error you think it shouldn't
-    have, try `rapply`.
-  - If `rapply` loops on typeclass resolution, try `rapply'` or
-    `nrapply'`. The former starts with as many arguments as possible
-    and tries decreasing the number. The latter will stop Coq from doing
-    a typeclass search.  Similarly, if `refine` loops, try `nrefine`.
+    have, try `nrapply`.
+  - If you want to use type class resolution as well, try `rapply`.
+    But it's better to use `nrapply` if it works.
+  - You could add a prime to the tactic, to try with many arguments
+    first, decreasing the number on each try.
   - If you don't want Coq to create evars for certain subgoals,
     add an `s` to the tactic name to make it use `simple refine`.
 
+- `lhs`, `lhs_V`, `rhs`, `rhs_V`:  Defined in `Basics/Tactics`.
+  These are tacticals that apply a specified tactic to one side
+  of an equality.  E.g. `lhs nrapply concat_1p.`
+
+- `transparent assert`: Defined in `Basics/Overture`, this tactic is
+  like `assert` but produces a transparent subterm rather than an
+  opaque one.  Due to restrictions of tactic notations, you have to
+  write `transparent assert (foo : (bar baz))` rather than
+  `transparent assert (foo : bar baz)`.
+
+- `issig`: Defined in `Basics/Tactics`, this tactic proves automatically
+  that a record type is equivalent to a nested sigma-type.
+
+- `make_equiv`: Defined in `Basics/Equivalences`, this tactic can prove
+  two types are equivalent if the proof involves juggling components.
+  See also `make_equiv_contr_basedpaths`.
+
+- `pointed_reduce`: Defined in `Pointed/Core`, this tactic lets you
+  assume that functions are strictly pointed.  See related tactics there.
+
+- `strip_truncations`, `strip_modalities` and `strip_reflections`: These
+  let you lift an element from `O X` to `X` when the goal is `O`-local,
+  for various `O`.
+
+- `simpl rewrite`: Defined in `Tactics`, this tactic applies `simpl`
+  to the type of a lemma, and to the goal, before rewriting the goal
+  with the lemma.  In particular, this is useful for rewriting with
+  lemmas containing definitions like `compose` that appear unfolded in
+  the goal: if the operation has `Arguments ... / .` as above then
+  `simpl` will unfold it.
+
+- `binder apply`: Defined in `Tactics/BinderApply`, this tactic
+  applies a lemma inside of a lambda abstraction, in the goal or in a
+  hypothesis.
+
   
-## 1.12. Contributing to the library ##
+## 12. Contributing to the library ##
 
-### 1.12.1. Fork & Pull ###
+### 12.1. Fork & Pull ###
 
 We mainly work by the "Fork & Pull" model.  Briefly: to contribute,
 [create your own fork][fork] of the repository, do your main work
 there, and [issue pull requests][pull] when work is ready to be
-brought into the main library.  Direct pushes to the library should be
-restricted to minor edits, in roughly [the sense of Wikipedia][minor]:
-improvements to documentation, typo corrections, etc.
+brought into the main library.  Direct pushes to the library should
+never be made.
 
 There are various reasons for preferring the fork/pull workflow.
 Firstly, it helps maintain code consistency.  Secondly, it makes it
@@ -1154,7 +1242,7 @@ survey changes grouped into pull requests than in individual commits.
 Thirdly, it means we can make our work in progress as messy and
 uncertain as we want, while keeping the main library clean and tidy.
 
-It is suggested that you submit your pull request not from the master
+Submit your pull request not from the master
 branch of your fork, but from another branch created specially for
 that purpose.  Among other things, this allows you to continue
 developing on your fork without changing the pull request, since a
@@ -1169,9 +1257,9 @@ on each other.
 
 [minor]: http://en.wikipedia.org/wiki/Help:Minor_edit
 
-### 1.12.2. Approval of pull requests ###
+### 12.2. Approval of pull requests ###
 
-Before being merged, pull requests must be approved by one or two of
+Before being merged, pull requests must be approved by one of
 the core developers, not counting whoever submitted it.  An approval
 can be an official "Approving review" through the GitHub UI, or just a
 comment such as LGTM ("Looks Good To Me").  Currently the rules are:
@@ -1180,32 +1268,31 @@ comment such as LGTM ("Looks Good To Me").  Currently the rules are:
   merging (which doesn't always mean making the changes, but a
   discussion must be had and resolved).
 
-- In general, a pull request should not be merged unless Travis CI
-  confirms that it builds successfully.  Exceptions to this rule
-  sometimes have to be made if the Travis configuration is broken for
+- In general, a pull request should not be merged unless the CI tests
+  confirm that it builds successfully.  Exceptions to this rule
+  sometimes have to be made if the CI configuration is broken for
   some unrelated reason, but in that case it is better if the
   person(s) approving the pull request confirms locally that it builds
   successfully.
 
-  Note also that Travis doesn't automatically restart itself on a pull
+  Note also that the CI doesn't automatically restart itself on a pull
   request when the master branch changes.  Thus, if other pull
   requests have been merged in the interval since a given pull request
   was first submitted, it may be necessary to rebase that pull request
   against the new master, to make
   sure before merging it that it won't break the master branch.
 
-- In the absence of objections, two approvals suffice for a pull
-  request to be merged.  Thus, instead of giving a second approval one
-  may just merge the pull request.
+- In the absence of objections, one approval suffices for a pull
+  request to be merged.
 
-- In the absence of objections but with only one approval, a pull
-  request may be merged if at least 48 hours have passed after its
-  submission.
+- In the absence of objections, a minor pull request may be merged
+  if at least 48 hours have passed after its submission.  In some
+  cases, this can be done immediately.
 
-If a pull request is lacking even one approval and hasn't received any
+If a pull request is lacking approval and hasn't received any
 discussion, feel free to bump it back to attention with a comment.
 
-### 1.12.3. Commit messages ###
+### 12.3. Commit messages ###
 
 Please try to keep commit messages clear and informative.  We don’t
 currently have a specific preferred convention, but the answers
@@ -1217,12 +1304,12 @@ Some good examples, showing what kind of change was made (additions,
 updates, fixes), and what material it was on:
 
 - "adapt to the new version of coqtop by disabling the native compiler"
-- "Resolved universe inconsistency in Freudenthal."
+- "resolved universe inconsistency in Freudenthal"
 - "epis are surjective"
 
 Some bad examples:
 
-- "further progess"  Progress in what files?
+- "further progress"  Progress in what files?
 - "Bug in [Equivalences.v]."  Was the bug fixed, or just noticed and
   flagged in comments, or what?
 - "asdfjkl"
@@ -1231,20 +1318,20 @@ Some bad examples:
 
 [commits2]: http://stackoverflow.com/questions/3580013/should-i-use-past-or-present-tense-in-git-commit-messages
 
-### 1.12.4. Creating new files ###
+### 12.4. Creating new files ###
 
-If you create a new file, `make` will only compile it if it is being tracked by
-`git`, so you will need to `git add` it.
+If you create a new file, `make` will only compile it if it is being
+tracked by `git`, so you will need to `git add` it.
 
 You will probably also want to add your new file to `HoTT.v`, unless
 it is outside the core (e.g. in `contrib/`) or should not be exported
 for some other reason.
 
-### 1.12.5. Travis ###
+### 12.5. Travis ###
 
 We use the [Travis Continuous Integration Platform][travis] to check
 that pull requests do not break anything, and also to automatically
-update various things (such as the documentation, proviola, and
+update various things (such as the documentation and
 dependency graph linked on the [project wiki][wiki]).  Normally you
 shouldn't need to know anything about this; Travis automatically
 checks every pull request made to the central repository.
@@ -1253,7 +1340,7 @@ checks every pull request made to the central repository.
 
 [wiki]: https://github.com/HoTT/HoTT/wiki
 
-### 1.12.6. Git rebase ###
+### 12.6. Git rebase ###
 
 If the master branch has diverged in some significant way since a pull
 request was made, then merging it may result in non-compiling code.
@@ -1271,7 +1358,7 @@ branch.  We encourage the use of `rebase` if you are comfortable with
 it; but for newcomers to git, rebasing can be intimidating, so merges
 are also perfectly acceptable.
 
-### 1.12.7. Timing scripts ###
+### 12.7. Timing scripts ###
 
 There are scripts in `etc/timing` to track (compile-time) performance
 changes in the library.  When you make large changes, you may want to
@@ -1310,20 +1397,20 @@ performance table.
 See the comments at the top of `make-pretty-timed-diff.sh` for more
 detailed instructions and caveats.
 
-## 1.13. Bugs in Coq ##
+## 13. Bugs in Coq ##
 
 More often than we would like, we run across bugs in Coq.  A sure sign
 of a bug in Coq is when you get a message about an "Anomaly", but a
 bug can also be unjustifiable behavior.  If you aren't sure whether
 something is a bug in Coq, feel free to [open an issue][new issue]
-about it on the HoTT GitHub project.
+about it on the Coq-HoTT GitHub project.
 
 [new issue]: https://github.com/HoTT/HoTT/issues/new
 
-### 1.13.1. Reporting bugs ###
+### 13.1. Reporting bugs ###
 
 Bugs in Coq should be reported on the [Coq bug tracker][bugs].  You
-should probably search the tracker first to see whether your bug has
+should search the tracker first to see whether your bug has
 already been reported.
 
 After reporting a bug, you may need to add a temporary workaround to
@@ -1333,7 +1420,7 @@ way when the bug is fixed, we can remove the workaround.
 
 [bugs]: https://coq.inria.fr/bugs
 
-### 1.13.2. Minimizing bugs ###
+### 13.2. Minimizing bugs ###
 
 When submitting a bug report, it is appreciated to submit a minimal
 test example.  Since the HoTT library is quite large, it can be quite
@@ -1354,16 +1441,15 @@ available in his [coq-tools][coq-tools] repository.  To use it:
    it as much as possible.
 
 You will need to pass the bug-finder several arguments to tell it to
-use the HoTT version of Coq and where to find the rest of the library;
+pass the right flags and where to find the rest of the library;
 a common invocation would be something like
 
-    $ /path/to/find-bug.py --coqc ../hoqc --coqtop ../hoqtop -R . HoTT Path/To/Buggy.v bug_minimized.v
+    $ /path/to/find-bug.py --arg -noinit --arg -indices-matter -R . HoTT Path/To/Buggy.v bug_minimized.v
 
 When it exits, the minimized code producing the bug will be in
 `bug_minimized.v`.
 
-There are a few "gotchas" to be aware of when using the bug-finder
-script with the HoTT library.  One is that sometimes `coqc` and
+Note that sometimes `coqc` and
 `coqtop` can exhibit different behavior, and one may produce a bug
 while the other doesn't.  (One reason for this is that they give
 different names to universe parameters, `Top.1` versus `Filename.1`,
@@ -1376,55 +1462,6 @@ both `coqc` and `coqtop`, but you can tell it to "fake" `coqc` using
 `coqtop` by passing the argument `--coqc-as-coqtop` instead of
 `--coqc`.
 
-Another "gotcha" is that with the above invocation, the minimized file
-will produce the bug with the `hoq*` scripts, but not necessarily with
-the ordinary `coq*` executables, because the HoTT standard library is
-modified.  Before submitting a bug report, you should check whether
-the minimized file gives the bug with the ordinary Coq executables
-(which can be found in `coq-HoTT/bin`).  If not, you may need to add a
-bit to it.  Often it is enough to add at the top some of the flags
-that the HoTT standard library turns on, such as
-
-```coq
-Global Set Universe Polymorphism.
-Global Set Asymmetric Patterns.
-Global Set Primitive Projections.
-Global Set Nonrecursive Elimination Schemes.
-```
-
-If this isn't good enough, then you can try pasting in more of the
-HoTT standard library.  For instance, you may need to redefine `sig`
-after setting universe polymorphism on.  A solution that almost always
-works is to insert
-
-```coq
-Module Import Coq.
-Module Import Init.
-Module Import Notations.
-(* paste contents of coq/theories/Init/Notations.v here *)
-End Notations.
-Module Import Logic.
-(* paste contents of coq/theories/Init/Logic.v here *)
-End Logic.
-Module Import Datatypes.
-(* paste contents of coq/theories/Init/Datatypes.v here *)
-End Datatypes.
-Module Import Specif.
-(* paste contents of coq/theories/Init/Specif.v here *)
-End Specif.
-End Init.
-End Coq.
-```
-
-and then replace all `Require Import`s in the pasted files with simply
-`Import`, remove the definition of `nat` (because there's no way to
-get special syntax for it), and possibly remove dependent choice.  You
-can then run the bug-finder on this file again to remove the parts of
-the pasted stdlib that aren't needed, telling it to use the unmodified
-Coq executables, e.g.
-
-    $ /path/to/find-bug.py --coqc ../coq-HoTT/bin/coqc --coqtop ../coq-HoTT/bin/coqtop bug_minimized.v bug_minimized_2.v
-
 [coq-tools]: https://github.com/JasonGross/coq-tools
 
 [instance bug]: https://coq.inria.fr/bugs/show_bug.cgi?id=3863
diff --git a/contrib/HoTTBook.v b/contrib/HoTTBook.v
index 958b10be596..44bc5a0846d 100644
--- a/contrib/HoTTBook.v
+++ b/contrib/HoTTBook.v
@@ -58,7 +58,7 @@
 *)
 
 From HoTT Require Import Basics Truncations.
-From HoTT Require Idempotents Spaces.Spheres Spaces.No.
+From HoTT Require Idempotents Spaces.No Spaces.Nat.
 From HoTT Require HIT.V HIT.Flattening Homotopy.WhiteheadsPrinciple Homotopy.Hopf.
 From HoTT Require Categories.
 From HoTT Require Metatheory.IntervalImpliesFunext Metatheory.UnivalenceImpliesFunext.
@@ -309,7 +309,7 @@ Definition Book_2_12_5 := @HoTT.Types.Sum.equiv_path_sum.
 (* ================================================== thm:path-nat *)
 (** Theorem 2.13.1 *)
 
-Definition Book_2_13_1 := @HoTT.Spaces.Nat.Core.equiv_path_nat.
+Definition Book_2_13_1 := @HoTT.Spaces.Nat.Paths.equiv_path_nat.
 
 (* ================================================== thm:prod-ump *)
 (** Theorem 2.15.2 *)
@@ -345,7 +345,7 @@ Definition Book_3_1_3 := @HoTT.Types.Empty.istrunc_Empty (-2).
 (* ================================================== thm:nat-set *)
 (** Example 3.1.4 *)
 
-Definition Book_3_1_4 := @HoTT.Spaces.Nat.Core.hset_nat.
+Definition Book_3_1_4 := @HoTT.Spaces.Nat.Core.ishset_nat.
 
 (* ================================================== thm:isset-prod *)
 (** Example 3.1.5 *)
diff --git a/contrib/HoTTBookExercises.v b/contrib/HoTTBookExercises.v
index 3dfb3cbff5b..9595407da5c 100644
--- a/contrib/HoTTBookExercises.v
+++ b/contrib/HoTTBookExercises.v
@@ -26,7 +26,7 @@
 From HoTT Require Import Basics Types HProp HSet Projective
      TruncType Truncations Modalities.Notnot Modalities.Open Modalities.Closed
      BoundedSearch Equiv.BiInv Spaces.Nat Spaces.Torus.TorusEquivCircles
-     Metatheory.Core Metatheory.FunextVarieties.
+     Classes.implementations.peano_naturals Metatheory.Core Metatheory.FunextVarieties.
 
 Local Open Scope nat_scope.
 Local Open Scope type_scope.
@@ -53,8 +53,8 @@ Section Book_1_2_prod.
   Variable A B : Type.
 
   (** Recursor with projection functions instead of pattern-matching. *)
-  Let prod_rec_proj C (g : A -> B -> C) (p : A * B) : C :=
-    g (fst p) (snd p).
+  Let prod_rec_proj C (g : A -> B -> C) (p : A * B) : C
+    := g (fst p) (snd p).
   Definition Book_1_2_prod := prod_rec_proj.
 
   Proposition Book_1_2_prod_fst : fst = prod_rec_proj A (fun a b => a).
@@ -75,8 +75,8 @@ Section Book_1_2_sig.
   Variable B : A -> Type.
 
   (** Non-dependent recursor with projection functions instead of pattern matching. *)
-  Let sig_rec_proj C (g : forall (x : A), B x -> C) (p : exists (x : A), B x) : C :=
-    g (pr1 p) (pr2 p).
+  Let sig_rec_proj C (g : forall (x : A), B x -> C) (p : exists (x : A), B x) : C
+    := g (pr1 p) (pr2 p).
   Definition Book_1_2_sig := @sig_rec_proj.
 
   Proposition Book_1_2_sig_fst : @pr1 A B = sig_rec_proj A (fun a => fun b => a).
@@ -98,8 +98,8 @@ Definition Book_1_3_prod_lib := @HoTT.Types.Prod.prod_ind.
 Section Book_1_3_prod.
   Variable A B : Type.
 
-  Let prod_ind_eta (C : A * B -> Type) (g : forall (x : A) (y : B), C (x, y)) (x : A * B) : C x :=
-    transport C (HoTT.Types.Prod.eta_prod x) (g (fst x) (snd x)).
+  Let prod_ind_eta (C : A * B -> Type) (g : forall (x : A) (y : B), C (x, y)) (x : A * B) : C x
+    := transport C (HoTT.Types.Prod.eta_prod x) (g (fst x) (snd x)).
   Definition Book_1_3_prod := prod_ind_eta.
 
   Proposition Book_1_3_prod_refl : forall C g a b, prod_ind_eta C g (a, b) = g a b.
@@ -115,8 +115,8 @@ Section Book_1_3_sig.
 
   Let sig_ind_eta (C : (exists (a : A), B a) -> Type)
                           (g : forall (a : A) (b : B a), C (a; b))
-                          (x : exists (a : A), B a) : C x :=
-    transport C (HoTT.Types.Sigma.eta_sigma x) (g (pr1 x) (pr2 x)).
+                          (x : exists (a : A), B a) : C x
+    := transport C (HoTT.Types.Sigma.eta_sigma x) (g (pr1 x) (pr2 x)).
   Definition Book_1_3_sig := sig_ind_eta.
 
   Proposition Book_1_3_sig_refl : forall C g a b, sig_ind_eta C g (a; b) = g a b.
@@ -128,7 +128,37 @@ End Book_1_3_sig.
 (* ================================================== ex:iterator *)
 (** Exercise 1.4 *)
 
+Section Book_1_4.
+  Fixpoint Book_1_4_iter (C : Type) (c0 : C) (cs : C -> C) (n : nat) : C
+    := match n with
+      | O => c0
+      | S m => cs (Book_1_4_iter C c0 cs m)
+      end.
+
+  Definition Book_1_4_rec' (C : Type) (c0 : C) (cs : nat -> C -> C) : nat -> nat * C
+    := Book_1_4_iter (nat * C) (O, c0) (fun x => (S (fst x), cs (fst x) (snd x))).
+  
+  Definition Book_1_4_rec (C : Type) (c0 : C) (cs : nat -> C -> C) (n : nat) : C
+    := snd (Book_1_4_rec' C c0 cs n).
+
+  Lemma Book_1_4_aux : forall C c0 cs n, fst (Book_1_4_rec' C c0 cs n) = n.
+  Proof.
+    intros C c0 cs n. induction n as [| m IH].
+    - simpl. reflexivity.
+    - cbn. exact (ap S IH).
+  Qed.
 
+  Proposition Book_1_4_eq
+    : forall C c0 cs n, Book_1_4_rec C c0 cs n = nat_rect (fun _ => C) c0 cs n.
+  Proof. 
+    intros C c0 cs n. induction n as [| m IH].
+    - simpl. reflexivity.
+    - change (cs (fst (Book_1_4_rec' C c0 cs m)) (Book_1_4_rec C c0 cs m)
+              = cs m (nat_rect (fun _ => C) c0 cs m)).
+      lhs rapply (ap (fun x => cs x _) (Book_1_4_aux _ _ _ _)).
+      exact (ap (cs m) IH).
+  Qed.
+End Book_1_4.
 
 (* ================================================== ex:sum-via-bool *)
 (** Exercise 1.5 *)
@@ -157,57 +187,124 @@ End Book_1_5.
 (* ================================================== ex:prod-via-bool *)
 (** Exercise 1.6 *)
 
+Section Book_1_6.
+  Context `{Funext}.
+
+  Definition Book_1_6_prod (A B : Type) := forall x : Bool, (if x then A else B).
+
+  Definition Book_1_6_mk_pair {A B : Type} (a : A) (b : B) : Book_1_6_prod A B
+    := fun x => match x with
+              | true => a
+              | false => b
+              end.
+
+  Notation "( a , b )" := (Book_1_6_mk_pair a b) (at level 0).
+  Notation "'pr1' p" := (p true) (at level 0).
+  Notation "'pr2' p" := (p false) (at level 0).
+
+  Definition Book_1_6_eq {A B : Type} (p : Book_1_6_prod A B) : (pr1 p, pr2 p) == p
+    := fun x => match x with
+              | true => 1
+              | false => 1
+              end.
+
+  Theorem Book_1_6_id {A B : Type} (a : A) (b : B) : Book_1_6_eq (a, b) = (fun x => 1).
+  Proof.
+    apply path_forall. intros x. destruct x; reflexivity.
+  Qed.
+
+  Definition Book_1_6_eta {A B : Type} (p : Book_1_6_prod A B) : (pr1 p, pr2 p) = p
+    := path_forall (pr1 p, pr2 p) p (Book_1_6_eq p).
 
+  Definition Book_1_6_ind {A B : Type} (C : Book_1_6_prod A B -> Type) (f : forall a b, C (a, b))
+    (p : Book_1_6_prod A B) : C p
+    := transport C (Book_1_6_eta p) (f (pr1 p) (pr2 p)).
+
+  Theorem Book_1_6_red {A B : Type} (C : Book_1_6_prod A B -> Type) f a b
+    : Book_1_6_ind C f (a, b) = f a b.
+  Proof.
+    unfold Book_1_6_ind, Book_1_6_eta. simpl.
+    rewrite Book_1_6_id, path_forall_1.
+    reflexivity.
+  Qed.
+End Book_1_6.
 
 (* ================================================== ex:pm-to-ml *)
 (** Exercise 1.7 *)
 
+Section Book_1_7.
+  Definition Book_1_7_id {A : Type}
+    : forall {x y : A} (p : x = y), (x; 1) = (y; p) :> { a : A & x = a }
+    := paths_ind' (fun (x y : A) (p : x = y) => (x; 1) = (y; p)) (fun x => 1).
 
+  Definition Book_1_7_transport {A : Type} (P : A -> Type)
+    : forall {x y : A} (p : x = y), P x -> P y
+    := paths_ind' (fun (x y : A) (p : x = y) => P x -> P y) (fun x => idmap).
+
+  Definition Book_1_7_ind' {A : Type} (a : A) (C : forall x, (a = x) -> Type)
+    (c : C a 1) (x : A) (p : a = x)
+    : C x p
+    := Book_1_7_transport (fun r => C (pr1 r) (pr2 r)) (Book_1_7_id p) c.
+
+  Definition Book_1_7_eq {A : Type} (a : A) (C : forall x, (a = x) -> Type) (c : C a 1)
+    : Book_1_7_ind' a C c a 1 = c
+    := 1.
+End Book_1_7.
 
 (* ================================================== ex:nat-semiring *)
 (** Exercise 1.8 *)
 
-Fixpoint rec_nat' (C : Type) c0 cs (n : nat) : C :=
-  match n with
-    O => c0
-  | S m => cs m (rec_nat' C c0 cs m)
-  end.
+Section Book_1_8.
+  Fixpoint Book_1_8_rec_nat (C : Type) c0 cs (n : nat) : C
+    := match n with
+      | O => c0
+      | S m => cs m (Book_1_8_rec_nat C c0 cs m)
+      end.
 
-Definition add : nat -> nat -> nat :=
-  rec_nat' (nat -> nat) (fun m => m) (fun n g m => (S (g m))).
+  Definition Book_1_8_add : nat -> nat -> nat
+    := Book_1_8_rec_nat (nat -> nat) (fun m => m) (fun n g m => (S (g m))).
 
-Definition mult : nat -> nat -> nat  :=
-  rec_nat' (nat -> nat) (fun m => 0) (fun n g m => add m (g m)).
+  Definition Book_1_8_mult : nat -> nat -> nat
+    := Book_1_8_rec_nat (nat -> nat) (fun m => 0) (fun n g m => Book_1_8_add m (g m)).
 
-(* rec_nat' gives back a function with the wrong argument order, so we flip the
-   order of the arguments p and q *)
-Definition exp : nat -> nat -> nat  :=
-  fun p q => (rec_nat' (nat -> nat) (fun m => (S 0)) (fun n g m => mult m (g m))) q p.
+  (* [Book_1_8_rec_nat] gives back a function with the wrong argument order, so we flip the order of the arguments [p] and [q]. *)
+  Definition Book_1_8_exp : nat -> nat -> nat
+    := fun p q =>
+        (Book_1_8_rec_nat (nat -> nat) (fun m => (S 0)) (fun n g m => Book_1_8_mult m (g m))) q p.
 
-Example add_example: add 32 17 = 49. Proof. reflexivity. Defined.
-Example mult_example: mult 20 5 = 100. Proof. reflexivity. Defined.
-Example exp_example: exp 2 10 = 1024. Proof. reflexivity. Defined.
+  Example add_example: Book_1_8_add 32 17 = 49 := 1.
+  Example mult_example: Book_1_8_mult 20 5 = 100 := 1.
+  Example exp_example: Book_1_8_exp 2 10 = 1024 := 1.
 
-(* To do: proof that these form a semiring *)
+  Definition Book_1_8_semiring := HoTT.Classes.implementations.peano_naturals.nat_semiring.
+End Book_1_8.
 
 (* ================================================== ex:fin *)
 (** Exercise 1.9 *)
 
+Section Book_1_9.
+  Fixpoint Book_1_9_Fin (n : nat) : Type
+    := match n with
+      | O => Empty
+      | S m => (Book_1_9_Fin m) + Unit
+      end.
 
+  Definition Book_1_9_fmax (n : nat) : Book_1_9_Fin (S n) := inr tt.
+End Book_1_9.
 
 (* ================================================== ex:ackermann *)
 (** Exercise 1.10 *)
 
-Fixpoint ack (n m : nat) : nat :=
-  match n with
-  | O => S m
-  | S p => let fix ackn (m : nat) :=
-               match m with
-                 | O => ack p 1
-                 | S q => ack p (ackn q)
-               end
-           in ackn m
-  end.
+Fixpoint ack (n m : nat) : nat 
+  := match n with
+    | O => S m
+    | S p => let fix ackn (m : nat)
+              := match m with
+                | O => ack p 1
+                | S q => ack p (ackn q)
+                end
+            in ackn m
+    end.
 
 Definition Book_1_10 := ack.
 
@@ -275,17 +372,19 @@ End Book_1_13.
 (* ================================================== ex:without-K *)
 (** Exercise 1.14 *)
 
-
+(** There is no adequate type family C : Pi_{x, y, p} U  such that C(x, x, p) is p = refl x definitionally. *)
 
 (* ================================================== ex:subtFromPathInd *)
 (** Exercise 1.15 *)
 
-(* concat_A1p? *)
+Definition Book_1_15_paths_rec {A : Type} {C : A -> Type} {x y : A} (p : x = y) : C x -> C y 
+  := match p with 1 => idmap end.
+(** This is exactly the definition of [transport] from Basics.Overture. *)
 
 (* ================================================== ex:add-nat-commutative *)
 (** Exercise 1.16 *)
 
-
+Definition Book_1_16 := HoTT.Spaces.Nat.Core.nat_add_comm.
 
 (* ================================================== ex:basics:concat *)
 (** Exercise 2.1 *)
@@ -495,7 +594,7 @@ End Book_2_7.
 (* ================================================== ex:ap-coprod *)
 (** Exercise 2.8 *)
 
-
+Definition Book_2_8 := @HoTT.Types.Sum.ap_functor_sum.
 
 (* ================================================== ex:coprod-ump *)
 (** Exercise 2.9 *)
@@ -510,7 +609,7 @@ Definition coprod_ump1 {A B X} : (A + B -> X) -> (A -> X) * (B -> X) :=
 (* To create a function on the direct sum from functions on the summands, work
    by cases *)
 Definition coprod_ump2 {A B X} : (A -> X) * (B -> X) -> (A + B -> X) :=
-  prod_rect (fun _ => A + B -> X) (fun f g => sum_rect (fun _ => X) f g).
+  prod_ind (fun _ => A + B -> X) (fun f g => sum_ind (fun _ => X) f g).
 
 Definition Book_2_9 {A B X} `{Funext} : (A -> X) * (B -> X) <~> (A + B -> X).
   apply (equiv_adjointify coprod_ump2 coprod_ump1).
@@ -558,12 +657,20 @@ End TwoTen.
 (* ================================================== ex:pullback *)
 (** Exercise 2.11 *)
 
+(** The definition of commutative squares in HoTT.Limits.Pullback is slightly different, using a homotopy between the composites instead of a path. *)
 
+Definition Book_2_11 `{H : Funext} {X A B C} (f : A -> C) (g : B -> C)
+  : (X -> HoTT.Limits.Pullback.Pullback f g)
+    <~> HoTT.Limits.Pullback.Pullback (fun h : X -> A => f o h) (fun k : X -> B => g o k)
+  := HoTT.Limits.Pullback.equiv_ispullback_commsq f g
+    oE (HoTT.Limits.Pullback.equiv_pullback_corec f g)^-1.
 
 (* ================================================== ex:pullback-pasting *)
 (** Exercise 2.12 *)
 
+Definition Book_2_12_i := @HoTT.Limits.Pullback.ispullback_pasting_left.
 
+Definition Book_2_12_ii := @HoTT.Limits.Pullback.ispullback_pasting_outer.
 
 (* ================================================== ex:eqvboolbool *)
 (** Exercise 2.13 *)
@@ -981,6 +1088,11 @@ Definition Book_3_19 := @HoTT.BoundedSearch.minimal_n.
 
 
 
+(* ================================================== ex:n-set *)
+(** Exercise 3.24 *)
+
+
+
 (* ================================================== ex:two-sided-adjoint-equivalences *)
 (** Exercise 4.1 *)
 
@@ -1057,7 +1169,7 @@ End Book_4_5.
 Section Book_4_6_i.
 
   Definition is_qinv {A B : Type} (f : A -> B)
-    := { g : B -> A & ((f o g == idmap) * (g o f == idmap))%type }.
+    := { g : B -> A & (f o g == idmap) * (g o f == idmap) }.
   Definition qinv (A B : Type)
     := { f : A -> B & is_qinv f }.
   Definition qinv_id A : qinv A A
@@ -1436,7 +1548,6 @@ Definition Book_6_1_ii := @HoTT.Cubical.DPath.dp_apD_pp.
 
 Definition Book_6_3 := @HoTT.Spaces.Torus.TorusEquivCircles.equiv_torus_prod_Circle.
 
-
 (* ================================================== ex:nspheres *)
 (** Exercise 6.4 *)
 
diff --git a/contrib/SetoidRewrite.v b/contrib/SetoidRewrite.v
index c37b5d5f8f3..d2bb4d7ad4e 100644
--- a/contrib/SetoidRewrite.v
+++ b/contrib/SetoidRewrite.v
@@ -15,7 +15,7 @@ From HoTT Require Import Basics.Overture Basics.Tactics.
 From HoTT Require Import Types.Forall.
 From Coq Require Setoids.Setoid.
 Import CMorphisms.ProperNotations.
-From HoTT Require Import WildCat.Core WildCat.Bifunctor WildCat.Prod
+From HoTT Require Import WildCat.Core
   WildCat.NatTrans WildCat.Equiv.
 
 #[export] Instance reflexive_proper_proxy {A : Type}
@@ -71,7 +71,7 @@ Defined.
 
 Open Scope signatureT_scope.
 
-#[export] Instance symmetry_flip {A B: Type} {f : A -> B}
+#[export] Instance symmetry_flip {A B : Type} {f : A -> B}
   {R : Relation A} {R' : Relation B} `{Symmetric _ R}
   (H0 : CMorphisms.Proper (R ++> R') f)
   : CMorphisms.Proper (R --> R') f.
@@ -80,7 +80,7 @@ Proof.
   apply H0. unfold CRelationClasses.flip. symmetry. exact Rab.
 Defined.
 
-#[export] Instance symmetric_flip_snd {A B C: Type} {R : Relation A}
+#[export] Instance symmetric_flip_snd {A B C : Type} {R : Relation A}
   {R' : Relation B} {R'' : Relation C} `{Symmetric _ R'}
   (f : A -> B -> C) (H1 : CMorphisms.Proper (R ++> R' ++> R'') f)
   : CMorphisms.Proper (R ++> R' --> R'') f.
@@ -88,7 +88,7 @@ Proof.
   intros a b Rab x y R'yx. apply H1; [ assumption | symmetry; assumption ].
 Defined.
 
-#[export] Instance IsProper_fmap {A B: Type} `{Is1Cat A}
+#[export] Instance IsProper_fmap {A B : Type} `{Is1Cat A}
   `{Is1Cat A} (F : A -> B) `{Is1Functor _ _ F} (a b : A)
   : CMorphisms.Proper (GpdHom ==> GpdHom) (@fmap _ _ _ _ F _ a b) := fun _ _ eq => fmap2 F eq.
 
@@ -99,7 +99,7 @@ Proof.
   intros f1 f2.
   apply (is0functor_postcomp a b c g ).
 Defined.
-                  
+
 #[export] Instance IsProper_catcomp {A : Type} `{Is1Cat A}
   {a b c : A}
   : CMorphisms.Proper (GpdHom ==> GpdHom ==> GpdHom)
@@ -111,7 +111,7 @@ Proof.
   exact eq_g.
 Defined.
 
-#[export] Instance gpd_hom_to_hom_proper {A B: Type} `{Is0Gpd A} 
+#[export] Instance gpd_hom_to_hom_proper {A B : Type} `{Is0Gpd A}
   {R : Relation B} (F : A -> B)
   `{CMorphisms.Proper _ (GpdHom ==> R) F}
   : CMorphisms.Proper (Hom ==> R) F.
@@ -119,37 +119,6 @@ Proof.
   intros a b eq_ab; apply H2; exact eq_ab.
 Defined.
 
-#[export] Instance Is1Functor_uncurry_bifunctor {A B C : Type}
-  `{Is1Cat A, Is1Cat B, Is1Cat C}
-  (F : A -> B -> C)
-  `{!IsBifunctor F}
-  `{forall a, Is1Functor (F a)}
-  `{forall b, Is1Functor (flip F b)}
-  : Is1Functor (uncurry F).
-Proof.
-  nrapply Build_Is1Functor.
-  - intros [a1 a2] [b1 b2] [f1 f2] [g1 g2] [eq_fg1 eq_fg2];
-      cbn in f1, f2, g1, g2, eq_fg1, eq_fg2. cbn.
-    rewrite eq_fg1, eq_fg2.
-    reflexivity.
-  - intros [a b]; cbn.
-    (* rewrite fmap_id generates an extra goal. Not sure how to get typeclass resolution to figure this out automatically. *)
-    rewrite (fmap_id _).
-    rewrite (fmap_id _).
-    rewrite cat_idl.
-    reflexivity.
-  - intros [a1 b1] [a2 b2] [a3 b3] [f1 f2] [g1 g2];
-      cbn in f1, f2, g1, g2.
-    cbn.
-    rewrite (fmap_comp _).
-    rewrite (fmap_comp _).
-    rewrite cat_assoc.
-    rewrite <- (cat_assoc _ (fmap (F a1) g2)).
-    rewrite <- (bifunctor_isbifunctor F f1 g2).
-    rewrite ! cat_assoc.
-    reflexivity.
-Defined.
-
 #[export] Instance gpd_hom_is_proper1 {A : Type} `{Is0Gpd A}
  : CMorphisms.Proper
      (Hom ==> Hom ==> CRelationClasses.arrow) Hom.
@@ -194,7 +163,7 @@ Defined.
 
 Proposition nat_equiv_faithful {A B : Type}
   {F G : A -> B} `{Is1Functor _ _ F}
-  `{!Is0Functor G, !Is1Functor G} 
+  `{!Is0Functor G, !Is1Functor G}
   `{!HasEquivs B} (tau : NatEquiv F G)
   : Faithful F -> Faithful G.
 Proof.
@@ -203,8 +172,7 @@ Proof.
        _ _ (cat_equiv_natequiv tau x))) in eq_Gf_Gg.
   cbn in eq_Gf_Gg.
   unfold cat_precomp in eq_Gf_Gg.
-  rewrite <- is1natural_natequiv in eq_Gf_Gg.
-  rewrite <- is1natural_natequiv in eq_Gf_Gg.
+  rewrite <- 2 (isnat tau) in eq_Gf_Gg.
   apply faithful_F.
   assert (X : RetractionOf (tau y)). {
     unshelve eapply Build_RetractionOf.
diff --git a/contrib/dune b/contrib/dune
index 59cc4c1dbef..9e6b1888322 100644
--- a/contrib/dune
+++ b/contrib/dune
@@ -1,6 +1,4 @@
 (coq.theory
  (name HoTT.Contrib)
  (package coq-hott)
- (flags -noinit -indices-matter -color on)
- (coqdoc_flags :standard --interpolate --utf8 --no-externals --parse-comments)
  (theories HoTT))
diff --git a/coq-hott.opam b/coq-hott.opam
index 252b805032e..c73490d0f94 100644
--- a/coq-hott.opam
+++ b/coq-hott.opam
@@ -16,8 +16,8 @@ license: "BSD-2-Clause"
 homepage: "http://homotopytypetheory.org/"
 bug-reports: "https://github.com/HoTT/HoTT/issues"
 depends: [
-  "dune" {>= "3.8"}
-  "coq" {>= "8.18.0"}
+  "dune" {>= "3.13"}
+  "coq" {>= "8.19.0"}
   "odoc" {with-doc}
 ]
 build: [
diff --git a/dune b/dune
index 70098e32031..7b6c83f7805 100644
--- a/dune
+++ b/dune
@@ -62,3 +62,70 @@
    (glob_files_rec contrib/*.v)))
  (action
   (run etc/emacs/run-etags.sh %{vfile})))
+
+; Common flags for Coq
+
+(env
+ (dev
+  (coq
+   (coqdoc_flags
+    :standard
+    --interpolate
+    --utf8
+    --no-externals
+    --parse-comments)
+   (flags -noinit -indices-matter -color on)))
+ (_
+  (coq
+   (coqdoc_flags
+    :standard
+    --interpolate
+    --utf8
+    --no-externals
+    --parse-comments)
+   (flags -noinit -indices-matter))))
+
+; Bench
+
+; The following rule allows you to bench the running time of a file using
+; "hyperfine". For this to work you must make a file called "file_to_bench"
+; which contains the path to the file you want to bench (with brackets around
+; it). For instance, if we wanted to bench the file
+; "theories/WildCat/Products.v", we would make a file called "file_to_bench" with
+; the following content:
+;
+; (theories/WildCat/Products.v)
+;
+; Afterwards you run "dune build @bench" and it will output the report.
+
+(rule
+ (alias bench)
+ (deps
+  (alias bench-hint)
+  (universe)
+  (sandbox always)
+  (glob_files_rec ./*.vo)
+  (:file
+   (include file_to_bench)))
+ (target bench_report)
+ (action
+  (progn
+   (with-outputs-to
+    %{target}
+    (progn
+     (copy %{file} benched_file.v)
+     (run
+      %{bin:hyperfine}
+      "%{bin:coqc} -R %{project_root}/theories HoTT -noinit -indices-matter benched_file.v")))
+   (echo "Bench finished, report at %{target}:\n\n")
+   (cat %{target}))))
+
+(rule
+ (alias bench-hint)
+ (deps
+  (universe)
+  (glob_files_rec ./*.vo)
+  %{bin:hyperfine}
+  (file file_to_bench))
+ (action
+  (run echo "Starting bench. This may take a while.")))
diff --git a/dune-project b/dune-project
index f2d07eebaed..bae6ea3cc3a 100644
--- a/dune-project
+++ b/dune-project
@@ -1,4 +1,4 @@
-(lang dune 3.8)
+(lang dune 3.13)
 
 (using coq 0.8)
 
@@ -26,4 +26,4 @@
   "To use the HoTT library, the following flags must be passed to coqc:\n  -noinit -indices-matter\nTo use the HoTT library in a project, add the following to _CoqProject:\n  -arg -noinit\n  -arg -indices-matter\n")
  (depends
   (coq
-   (>= 8.18.0))))
+   (>= 8.19.0))))
diff --git a/flake.lock b/flake.lock
index d3967100415..11a0e2a2468 100644
--- a/flake.lock
+++ b/flake.lock
@@ -5,11 +5,11 @@
         "systems": "systems"
       },
       "locked": {
-        "lastModified": 1705309234,
-        "narHash": "sha256-uNRRNRKmJyCRC/8y1RqBkqWBLM034y4qN7EprSdmgyA=",
+        "lastModified": 1710146030,
+        "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=",
         "owner": "numtide",
         "repo": "flake-utils",
-        "rev": "1ef2e671c3b0c19053962c07dbda38332dcebf26",
+        "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a",
         "type": "github"
       },
       "original": {
@@ -20,11 +20,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1708247094,
-        "narHash": "sha256-H2VS7VwesetGDtIaaz4AMsRkPoSLEVzL/Ika8gnbUnE=",
+        "lastModified": 1726042813,
+        "narHash": "sha256-LnNKCCxnwgF+575y0pxUdlGZBO/ru1CtGHIqQVfvjlA=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "045b51a3ae66f673ed44b5bbd1f4a341d96703bf",
+        "rev": "159be5db480d1df880a0135ca0bfed84c2f88353",
         "type": "github"
       },
       "original": {
diff --git a/flake.nix b/flake.nix
index 5242b70b3e3..8400403e7c1 100644
--- a/flake.nix
+++ b/flake.nix
@@ -7,34 +7,35 @@
     flake-utils.url = "github:numtide/flake-utils";
   };
 
-  outputs =
-    { self
-    , nixpkgs
-    , flake-utils
-    }:
-    flake-utils.lib.eachDefaultSystem (
-      system:
+  outputs = { self, nixpkgs, flake-utils }:
+    flake-utils.lib.eachDefaultSystem (system:
       let
         pkgs = nixpkgs.legacyPackages.${system};
-      in
-      {
+        makeDevShell = { coq ? pkgs.coq }:
+          let
+            coqPackages = pkgs.mkCoqPackages coq // {
+              __attrsFailEvaluation = true;
+            };
+          in { extraPackages ? [ coqPackages.coq-lsp ] }:
+          pkgs.mkShell {
+            buildInputs = with coqPackages;
+              [ pkgs.dune_3 pkgs.ocaml ] ++ extraPackages ++ [ coq ];
+          };
+      in {
         packages.default = pkgs.coqPackages.mkCoqDerivation {
           pname = "hott";
-          version = "8.18";
+          version = "8.19";
           src = self;
           useDune = true;
         };
 
-        devShells.default = pkgs.mkShell {
-          buildInputs = with pkgs.coqPackages_8_19; [
-            pkgs.dune_3
-            pkgs.ocaml
-            coq
-            coq-lsp
-          ];
-        };
+        devShells.default = makeDevShell { coq = pkgs.coq_8_20; } { };
+        devShells.coq_8_19 = makeDevShell { coq = pkgs.coq_8_19; } { };
+
+        # To use, pass --impure to nix develop
+        devShells.coq_master =
+          makeDevShell { coq = pkgs.coq.override { version = "master"; }; } { };
 
         formatter = pkgs.nixpkgs-fmt;
-      }
-    );
+      });
 }
diff --git a/test/Algebra/Groups/Presentation.v b/test/Algebra/Groups/Presentation.v
index 6baf11c6d15..c76df930aec 100644
--- a/test/Algebra/Groups/Presentation.v
+++ b/test/Algebra/Groups/Presentation.v
@@ -1,4 +1,5 @@
-From HoTT.Algebra.Groups Require Import Group Presentation.
+From HoTT Require Import Basics Spaces.Finite.Fin Spaces.Finite.FinSeq.
+From HoTT.Algebra.Groups Require Import Group Presentation FreeGroup.
 
 Local Open Scope mc_scope.
 Local Open Scope mc_mult_scope.
diff --git a/test/Algebra/Rings/Matrix.v b/test/Algebra/Rings/Matrix.v
new file mode 100644
index 00000000000..88632a6dfab
--- /dev/null
+++ b/test/Algebra/Rings/Matrix.v
@@ -0,0 +1,99 @@
+From HoTT Require Import Basics.
+From HoTT Require Import Algebra.Rings.Matrix.
+From HoTT Require Import Spaces.Nat.Core Spaces.List.Core.
+From HoTT Require Import Algebra.Rings.Z Spaces.Int Algebra.Rings.CRing.
+From HoTT Require Import Classes.interfaces.canonical_names.
+
+Local Open Scope mc_scope.
+Local Open Scope nat_scope.
+Local Open Scope list_scope.
+
+(** Matrices can be built with lists of lists. *)
+Definition test1 := Build_Matrix' nat 5 7
+   [ [  1 ,  2 ,  3 ,  4 ,  5 ,  6 ,  7 ]
+   , [  8 ,  9 , 10 , 11 , 12 , 13 , 14 ]
+   , [ 15 , 16 , 17 , 18 , 19 , 20 , 21 ]
+   , [ 22 , 23 , 24 , 25 , 26 , 27 , 28 ]
+   , [ 29 , 30 , 31 , 32 , 33 , 34 , 35 ] ]
+   ltac:(decide)
+   ltac:(decide).
+
+(** Malformed matrices are not accepted. *)
+Fail Definition test2 := Build_Matrix' nat 2 2
+   [ [ 1 , 2 ]
+   , [ 3 , 4 , 5] ]
+   ltac:(decide)
+   ltac:(decide).
+
+(** Matrices can also be built with functions. *)
+Definition test2_A := Build_Matrix nat 4 4 (fun i j _ _ => i * j).
+
+Definition test2_B := Build_Matrix' nat 4 4
+   [ [  0 ,  0 ,  0 ,  0 ]
+   , [  0 ,  1 ,  2 ,  3 ]
+   , [  0 ,  2 ,  4 ,  6 ]
+   , [  0 ,  3 ,  6 ,  9 ] ]
+   ltac:(decide)
+   ltac:(decide).
+
+Definition test2 : entries test2_A = entries test2_B := idpath.
+
+Local Open Scope int_scope.
+
+(** Matrices with ring entries can be multiplied *)
+
+(** This is the first matrix. *)
+Definition test3_A := Build_Matrix' cring_Z 3 2
+   [ [ 1 ,  3 ]
+   , [ 2 , -1 ]
+   , [ 1 ,  1 ] ]
+   ltac:(decide)
+   ltac:(decide).
+
+(** This is the second matrix. *)
+Definition test3_B := Build_Matrix' cring_Z 2 4
+   [ [  4 , 1 , 0 , -2 ]
+   , [ -1 , 1 , 5 ,  1 ] ]
+   ltac:(decide)
+   ltac:(decide).
+
+(** This is the expected result of the multiplication. *)
+Definition test3_AB := Build_Matrix' cring_Z 3 4
+   [ [  1 , 4 , 15 ,  1 ]
+   , [  9 , 1 , -5 , -5 ]
+   , [  3 , 2 ,  5 , -1 ] ]
+   ltac:(decide)
+   ltac:(decide).
+
+(** The entries should be the same, although the well-formedness proofs may differ definitionally. *)
+Definition test3 : entries (matrix_mult test3_A test3_B) = entries test3_AB := idpath.
+
+(** Here we check the minors of a matrix are computed correctly. *)
+
+Definition test4 := Build_Matrix' cring_Z 3 3
+   [ [  1 ,  3 ,  5 ]
+   , [  2 ,  4 ,  6 ]
+   , [  7 ,  8 ,  9 ] ]
+   ltac:(decide)
+   ltac:(decide).
+
+Definition test4_minor_0_1 := Build_Matrix' cring_Z 2 2
+   [ [  2 ,  6 ]
+   , [  7 ,  9 ] ]
+   ltac:(decide)
+   ltac:(decide).
+
+Definition test4_minor_0_1_eq
+   : entries (matrix_minor 0 1 test4) = entries test4_minor_0_1
+   := idpath.
+
+Definition test4_minor_1_1 := Build_Matrix' cring_Z 2 2
+   [ [  1 ,  5 ]
+   , [  7 ,  9 ] ]
+   ltac:(decide)
+   ltac:(decide).
+
+Definition test4_minor_1_1_eq
+   : entries (matrix_minor 1 1 test4) = entries test4_minor_1_1
+   := idpath.
+
diff --git a/test/Algebra/Rings/Ring.v b/test/Algebra/Rings/Ring.v
new file mode 100644
index 00000000000..c6653090f4d
--- /dev/null
+++ b/test/Algebra/Rings/Ring.v
@@ -0,0 +1,11 @@
+From HoTT Require Import Basics.Overture Algebra.Rings.Ring Algebra.Rings.CRing.
+From HoTT.Algebra Require Import Groups.Group AbGroups.AbelianGroup.
+From HoTT Require Import abstract_algebra.
+
+Local Open Scope path_scope.
+
+(** Test that opposite rings are definitionally involutive. *)
+Definition test1 (R : Ring) : R = (rng_op (rng_op R)) :> Ring := 1.
+  
+(** This may look funny, but you will see that Coq discards the [rng_op] during elaboration meaning that we only have [R = R] at the end. The reason this works is that [rng_op] takes in only a [Ring]. Afterwards, Coq is able to see that [rng_op (rng_op R)] should be a [CRing] and the coercion from [Ring] to [CRing] is reversible, therefore Coq tries to unify it with the original commutative ring. This behaviour is a bit surprising but is harmless so we just document it here. *)
+Definition test2 (R : CRing) : R = (rng_op (rng_op R)) :> CRing := 1.
diff --git a/test/Classes/ring_tac.v b/test/Classes/ring_tac.v
index 8368efd1975..2b304081c05 100644
--- a/test/Classes/ring_tac.v
+++ b/test/Classes/ring_tac.v
@@ -8,7 +8,7 @@ From HoTT Require Import
 Import Quoting.Instances.
 Generalizable Variables R.
 
-Lemma test1 `{IsSemiRing R}
+Lemma test1 `{IsSemiCRing R}
   : forall x y : R, x + (y * x) = x * (y + 1).
 Proof.
 intros.
@@ -18,7 +18,7 @@ Qed.
 Require Import
   HoTT.Classes.interfaces.naturals.
 
-Lemma test2 `{IsSemiRing R}
+Lemma test2 `{IsSemiCRing R}
   : forall x y : R, x + (y * x) = x * (y + 1).
 Proof.
 intros.
@@ -26,7 +26,7 @@ apply (by_quoting (naturals_to_semiring nat R)).
 compute. reflexivity.
 Qed.
 
-Lemma test3 `{IsSemiRing R}
+Lemma test3 `{IsSemiCRing R}
   (pa pb pc : R) :
   pa * (pb * pc)
 = pa * pb * pc.
@@ -36,7 +36,7 @@ apply (by_quoting (naturals_to_semiring nat R)). compute.
 reflexivity.
 Qed.
 
-Lemma test4 `{IsSemiRing R}
+Lemma test4 `{IsSemiCRing R}
   (a b : R)
   : a * b = b * a.
 Proof.
diff --git a/test/Spaces/List.v b/test/Spaces/List.v
new file mode 100644
index 00000000000..fc7ecd5f839
--- /dev/null
+++ b/test/Spaces/List.v
@@ -0,0 +1,114 @@
+From HoTT Require Import Basics.
+From HoTT.Spaces.List Require Import Core Theory.
+
+(** Here we check the number of universe variables for the definitions from List.Core *)
+Succeed Check list@{_}.
+Succeed Check nil@{_}.
+Succeed Check cons@{_}.
+Succeed Check list_rect@{_ _}.
+Succeed Check list_ind@{_ _}.
+Succeed Check list_rec@{_ _}.
+Succeed Check length@{_}.
+Succeed Check app@{_}.
+Succeed Check fold_left@{_ _}.
+Succeed Check fold_right@{_ _}.
+Succeed Check list_map@{_ _}.
+Succeed Check list_map2@{_ _ _}.
+Succeed Check reverse_acc@{_}.
+Succeed Check reverse@{_}.
+Succeed Check head@{_}.
+Succeed Check tail@{_}.
+Succeed Check last@{_}.
+Succeed Check nth@{_}.
+Succeed Check remove_last@{_}.
+Succeed Check seq_rev@{}.
+Succeed Check seq@{}.
+Succeed Check repeat@{_}.
+Succeed Check InList@{_}.
+Succeed Check for_all@{_ _}.
+
+(** Here we check the number of universe variables for the definitions from List.Theory *)
+Succeed Check length_0@{_}.
+Succeed Check app_nil@{_}.
+Succeed Check app_assoc@{_}.
+Succeed Check list_pentagon@{_}.
+Succeed Check length_app@{_}.
+Succeed Check equiv_inlist_app@{_}.
+Succeed Check fold_left_app@{_ _}.
+Succeed Check fold_right_app@{_ _}.
+Succeed Check length_list_map@{_ _}.
+Succeed Check inlist_map@{_ _}.
+Succeed Check inlist_map'@{_ _ _}.
+Succeed Check list_map_id@{_}.
+Succeed Check list_map_compose@{_ _ _}.
+Succeed Check length_list_map2@{_ _ _}.
+Succeed Check inlist_map2@{_ _ _ _}.
+Succeed Check list_map2_repeat_l@{_ _ _}.
+Succeed Check list_map2_repeat_r@{_ _ _}.
+Succeed Check length_reverse_acc@{_}.
+Succeed Check length_reverse@{_}.
+Succeed Check list_map_reverse_acc@{_ _}.
+Succeed Check list_map_reverse@{_ _}.
+Succeed Check reverse_acc_cons@{_}.
+Succeed Check reverse_cons@{_}.
+Succeed Check nth_lt@{_}.
+Succeed Check nth'@{_}.
+Succeed Check nth'_nth'@{_}.
+Succeed Check inlist_nth'@{_}.
+Succeed Check nth_nth'@{_}.
+Succeed Check nth'_cons@{_}.
+Succeed Check index_of@{_}.
+Succeed Check nth_list_map@{_ _}.
+Succeed Check nth'_list_map@{_ _}.
+Succeed Check nth'_list_map2@{_ _ _}.
+Succeed Check nth'_repeat@{_}.
+Succeed Check path_list_nth'@{_}.
+Succeed Check nth_app@{_}.
+Succeed Check nth_last@{_}.
+Succeed Check last_app@{_}.
+Succeed Check drop@{_}.
+Succeed Check drop_0@{_}.
+Succeed Check drop_1@{_}.
+Succeed Check drop_nil@{_}.
+Succeed Check drop_length_leq@{_}.
+Succeed Check length_drop@{_}.
+Succeed Check drop_inlist@{_}.
+Succeed Check take@{_}.
+Succeed Check take_0@{_}.
+Succeed Check take_nil@{_}.
+Succeed Check take_length_leq@{_}.
+Succeed Check length_take@{_}.
+Succeed Check take_inlist@{_}.
+Succeed Check remove@{_}.
+Succeed Check remove_0@{_}.
+Succeed Check remove_length_leq@{_}.
+Succeed Check length_remove@{_}.
+Succeed Check remove_inlist@{_}.
+Succeed Check length_seq_rev@{}.
+Succeed Check length_seq@{}.
+Succeed Check seq_rev_cons@{}.
+Succeed Check seq_succ@{}.
+Succeed Check seq_rev'@{}.
+Succeed Check seq'@{}.
+Succeed Check length_seq_rev'@{}.
+Succeed Check length_seq'@{}.
+Succeed Check seq_rev_seq_rev'@{}.
+Succeed Check seq_seq'@{}.
+Succeed Check nth_seq_rev@{}.
+Succeed Check nth_seq@{}.
+Succeed Check nth'_seq'@{}.
+Succeed Check length_repeat@{_}.
+Succeed Check inlist_repeat@{_}.
+Succeed Check for_all_inlist@{_ _}.
+Succeed Check inlist_for_all@{_ _}.
+Succeed Check for_all_list_map@{_ _ _ _}.
+Succeed Check for_all_list_map'@{_ _ _}.
+Succeed Check for_all_list_map2@{_ _ _ _ _ _}.
+Succeed Check for_all_list_map2'@{_ _ _ _ _ _}.
+Succeed Check fold_left_preserves@{_ _ _ _}.
+Succeed Check istrunc_for_all@{_ _}.
+Succeed Check istrunc_for_all'@{_ _}.
+Succeed Check for_all_repeat@{_ _}.
+Succeed Check list_sigma@{_ _ _}.
+Succeed Check length_list_sigma@{_ _ _}.
+Succeed Check decidable_for_all@{_ _}.
diff --git a/test/WildCat/Opposite.v b/test/WildCat/Opposite.v
index f505a900772..38d7aa0f157 100644
--- a/test/WildCat/Opposite.v
+++ b/test/WildCat/Opposite.v
@@ -1,11 +1,72 @@
-From HoTT Require Import Basics WildCat.Core WildCat.Opposite.
+From HoTT Require Import Basics WildCat.Core WildCat.Opposite WildCat.Equiv
+  WildCat.NatTrans WildCat.Bifunctor WildCat.Monoidal.
 
-(* Opposites are (almost) definitionally involutive. *)
+(** Opposites are definitionally involutive. *)
+Succeed Definition test A : A = (A^op)^op :> Type := 1.
+Succeed Definition test A `{x : IsGraph A} : x = @isgraph_op A^op (@isgraph_op A x) := 1.
+Succeed Definition test A `{x : Is01Cat A} : x = @is01cat_op A^op _ (@is01cat_op A _ x) := 1.
+Succeed Definition test A `{x : Is2Graph A} : x = @is2graph_op A^op _ (@is2graph_op A _ x) := 1.
+Succeed Definition test A `{x : Is1Cat A} : x = @is1cat_op A^op _ _ _ (@is1cat_op A _ _ _ x) := 1.
 
-Definition test1 A : A = (A^op)^op :> Type := 1.
-Definition test2 A `{x : IsGraph A} : x = isgraph_op (A := A^op) := 1.
-Definition test3 A `{x : Is01Cat A} : x = is01cat_op (A := A^op) := 1.
-Definition test4 A `{x : Is2Graph A} : x = is2graph_op (A := A^op) := 1.
+(** [core] only partially commutes with taking the opposite category. *)
+Succeed Definition test A `{HasEquivs A} : (core A)^op = core A^op :> Type := 1.
+Succeed Definition test A `{HasEquivs A} : isgraph_op (A:=core A) = isgraph_core (A:=A^op) := 1.
+Succeed Definition test A `{HasEquivs A} : is01cat_op (A:=core A) = is01cat_core (A:=A^op) := 1.
+Succeed Definition test A `{HasEquivs A} : is2graph_op (A:=core A) = is2graph_core (A:=A^op) := 1.
 
-(** Is1Cat is not definitionally involutive. *)
-Fail Definition test4 A `{x : Is1Cat A} : x = is1cat_op (A := A^op) := 1.
+(** The Opaque line reduces the time from 0.3s to 0.07s. *)
+Opaque compose_catie_isretr.
+Succeed Definition test A `{HasEquivs A} : is1cat_op (A:=core A) = is1cat_core (A:=A^op) := 1.
+
+(** Opposite functors are definitionally involutive. *)
+Succeed Definition test A B (F : A -> B) `{x : Is0Functor A B F}
+  : @is0functor_op _ _ F _ _ (@is0functor_op _ _ F _ _ x) = x
+  := 1.
+Succeed Definition test A B (F : A -> B) `{x : Is1Functor A B F}
+  : @is1functor_op _ _ F _ _ _ _ _ _ _ _ _ (@is1functor_op _ _ F _ _ _ _ _ _ _ _ _ x) = x
+  := 1.
+
+(** Opposite bifunctors are definitionally involutive. *)
+Succeed Definition test A B C (F : A -> B -> C) `{x : Is0Bifunctor A B C F}
+  : @is0bifunctor_op _ _ _ F _ _ _ (@is0bifunctor_op _ _ _ F _ _ _ x) = x
+  := 1.
+Succeed Definition test A B C (F : A -> B -> C) `{x : Is1Bifunctor A B C F}
+  : @is1bifunctor_op _ _ _ F _ _ _ _ _ _ _ _ _ _ _ _ _
+    (@is1bifunctor_op _ _ _ F _ _ _ _ _ _ _ _ _ _ _ _ _ x) = x
+  := 1.
+
+(** Opposite natural transformations are definitionally involutive. *)
+Succeed Definition test A `{Is01Cat A} B `{Is1Cat B} (F G : A -> B)
+  `{!Is0Functor F, !Is0Functor G} (n : NatTrans F G)
+  : nattrans_op (nattrans_op n) = n
+  := 1.
+
+(** Opposite natural equivalences are definitionally involutive. *)
+Succeed Definition test A `{Is01Cat A} B `{HasEquivs B} (F G : A -> B)
+  `{!Is0Functor F, !Is0Functor G} (n : NatEquiv F G)
+  : natequiv_op (natequiv_op n) = n
+  := 1.
+
+(** Opposite left unitors are *not* definitionally involutive. *)
+Fail Definition test A `{HasEquivs A} (unit : A)
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : LeftUnitor F unit)
+  : @left_unitor_op _ _ _ _ _ _ F unit _ _ (@left_unitor_op _ _ _ _ _ _ F unit _ _ a) = a
+  := 1.
+
+(** Opposite right unitors are *not* definitionally involutive. *)
+Fail Definition test A `{HasEquivs A} (unit : A)
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : RightUnitor F unit)
+  : @right_unitor_op _ _ _ _ _ _ F unit _ _ (@right_unitor_op _ _ _ _ _ _ F unit _ _ a) = a
+  := 1.
+
+(** Opposite associators are *not* definitionally involutive. *)
+Fail Definition test A `{HasEquivs A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : Associator F)
+  : @associator_op _ _ _ _ _ _ F _ _ (@associator_op _ _ _ _ _ _ F _ _ a) = a
+  := 1.
+
+(** Opposite braidings are definitionally involutive. *)
+Succeed Definition test A `{HasEquivs A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : Braiding F)
+  : @braiding_op _ _ _ _ _ _ _ _ _ (@braiding_op _ _ _ _ _ _ _ _ _ a) = a
+  := 1.
diff --git a/test/dune b/test/dune
index e3f943db450..08fb8df7c93 100644
--- a/test/dune
+++ b/test/dune
@@ -1,8 +1,6 @@
 (coq.theory
  (name HoTT.Tests)
- (theories HoTT)
- (flags -noinit -indices-matter -color on)
- (coqdoc_flags :standard --interpolate --utf8 --no-externals --parse-comments))
+ (theories HoTT))
 
 (include_subdirs qualified)
 
diff --git a/theories/Algebra/AbGroups/AbHom.v b/theories/Algebra/AbGroups/AbHom.v
index 0d3563860bc..b17076a97d5 100644
--- a/theories/Algebra/AbGroups/AbHom.v
+++ b/theories/Algebra/AbGroups/AbHom.v
@@ -1,8 +1,11 @@
 Require Import Basics Types.
 Require Import WildCat HSet Truncations.Core Modalities.ReflectiveSubuniverse.
-Require Import AbelianGroup Biproduct.
+Require Import Groups.QuotientGroup AbelianGroup Biproduct.
 
-(** * Homomorphisms of abelian groups form an abelian group. *)
+Local Open Scope mc_scope.
+Local Open Scope mc_add_scope.
+
+(** * Homomorphisms from a group to an abelian group form an abelian group. *)
 
 (** We can add group homomorphisms. *)
 Definition ab_homo_add {A : Group} {B : AbGroup} (f g : A $-> B)
@@ -13,11 +16,11 @@ Proof.
   exact (grp_prod_corec f g).
 Defined.
 
-(** We can negate an abelian group homomorphism by composing with ab_homo_negation. *)
+(** We can negate a group homomorphism by composing with [ab_homo_negation]. *)
 Global Instance negate_hom {A : Group} {B : AbGroup}
   : Negate (@Hom Group _ A B) := grp_homo_compose ab_homo_negation.
 
-(** For [A B : AbGroup], homomorphisms [A $-> B] form an abelian group. *)
+(** For [A] and [B] groups, with [B] abelian, homomorphisms [A $-> B] form an abelian group. *)
 Definition grp_hom `{Funext} (A : Group) (B : AbGroup) : Group.
 Proof.
   nrefine (Build_Group (GroupHomomorphism A B)
@@ -40,6 +43,125 @@ Proof.
   apply commutativity.
 Defined.
 
+(** ** Coequalizers *)
+
+(** Using the cokernel and addition and negation for the homs of abelian groups, we can define the coequalizer of two group homomorphisms as the cokernel of their difference. *)
+Definition ab_coeq {A B : AbGroup} (f g : GroupHomomorphism A B)
+  := ab_cokernel (ab_homo_add (negate_hom f) g).
+
+Definition ab_coeq_in {A B} {f g : A $-> B} : B $-> ab_coeq f g.
+Proof.
+  snrapply grp_quotient_map.
+Defined.
+
+Definition ab_coeq_glue {A B} {f g : A $-> B}
+  : ab_coeq_in (f:=f) (g:=g) $o f $== ab_coeq_in $o g.
+Proof.
+  intros x.
+  nrapply qglue.
+  apply tr.
+  by exists x.
+Defined.
+
+Definition ab_coeq_rec {A B : AbGroup} {f g : A $-> B}
+  {C : AbGroup} (i : B $-> C) (p : i $o f $== i $o g) 
+  : ab_coeq f g $-> C.
+Proof.
+  snrapply (grp_quotient_rec _ _ i).
+  cbn.
+  intros b H.
+  strip_truncations.
+  destruct H as [a q].
+  destruct q; simpl.
+  lhs nrapply grp_homo_op.
+  lhs nrapply (ap (.* _)).
+  1: apply grp_homo_inv.
+  apply grp_moveL_M1^-1.
+  exact (p a)^.
+Defined.
+
+Definition ab_coeq_rec_beta_in {A B : AbGroup} {f g : A $-> B}
+  {C : AbGroup} (i : B $-> C) (p : i $o f $== i $o g)
+  : ab_coeq_rec i p $o ab_coeq_in $== i
+  := fun _ => idpath.
+
+Definition ab_coeq_ind_hprop {A B f g} (P : @ab_coeq A B f g -> Type)
+  `{forall x, IsHProp (P x)}
+  (i : forall b, P (ab_coeq_in b))
+  : forall x, P x.
+Proof.
+  rapply Quotient_ind_hprop.
+  exact i.
+Defined.
+
+Definition ab_coeq_ind_homotopy {A B C f g}
+  {l r : @ab_coeq A B f g $-> C}
+  (p : l $o ab_coeq_in $== r $o ab_coeq_in) 
+  : l $== r.
+Proof.
+  srapply ab_coeq_ind_hprop.
+  exact p.
+Defined.
+
+Definition functor_ab_coeq {A B} {f g : A $-> B} {A' B'} {f' g' : A' $-> B'}
+  (a : A $-> A') (b : B $-> B') (p : f' $o a $== b $o f) (q : g' $o a $== b $o g)
+  : ab_coeq f g $-> ab_coeq f' g'.
+Proof.
+  snrapply ab_coeq_rec.
+  1: exact (ab_coeq_in $o b).
+  refine (cat_assoc _ _ _ $@ _ $@ cat_assoc_opp _ _ _).
+  refine ((_ $@L p^$) $@ _ $@ (_ $@L q)).
+  refine (cat_assoc_opp _ _ _ $@ (_ $@R a) $@ cat_assoc _ _ _).
+  nrapply ab_coeq_glue.
+Defined.
+
+Definition functor2_ab_coeq {A B} {f g : A $-> B} {A' B'} {f' g' : A' $-> B'}
+  {a a' : A $-> A'} {b b' : B $-> B'}
+  (p : f' $o a $== b $o f) (q : g' $o a $== b $o g)
+  (p' : f' $o a' $== b' $o f) (q' : g' $o a' $== b' $o g)
+  (s : b $== b')
+  : functor_ab_coeq a b p q $== functor_ab_coeq a' b' p' q'.
+Proof.
+  snrapply ab_coeq_ind_homotopy.
+  intros x.
+  exact (ap ab_coeq_in (s x)).
+Defined.
+
+Definition functor_ab_coeq_compose {A B} {f g : A $-> B}
+  {A' B'} {f' g' : A' $-> B'} 
+  (a : A $-> A') (b : B $-> B') (p : f' $o a $== b $o f) (q : g' $o a $== b $o g)
+  {A'' B''} {f'' g'' : A'' $-> B''}
+  (a' : A' $-> A'') (b' : B' $-> B'')
+  (p' : f'' $o a' $== b' $o f') (q' : g'' $o a' $== b' $o g')
+  : functor_ab_coeq a' b' p' q' $o functor_ab_coeq a b p q
+  $== functor_ab_coeq (a' $o a) (b' $o b) (hconcat p p') (hconcat q q').
+Proof.
+  snrapply ab_coeq_ind_homotopy.
+  simpl; reflexivity.
+Defined.
+
+Definition functor_ab_coeq_id {A B} (f g : A $-> B)
+  : functor_ab_coeq (f:=f) (g:=g) (Id _) (Id _) (hrefl _) (hrefl _) $== Id _.
+Proof.
+  snrapply ab_coeq_ind_homotopy.
+  reflexivity.
+Defined.
+
+Definition grp_iso_ab_coeq {A B} {f g : A $-> B} {A' B'} {f' g' : A' $-> B'}
+  (a : A $<~> A') (b : B $<~> B') (p : f' $o a $== b $o f) (q : g' $o a $== b $o g)
+  : ab_coeq f g $<~> ab_coeq f' g'.
+Proof.
+  snrapply cate_adjointify.
+  - exact (functor_ab_coeq a b p q).
+  - exact (functor_ab_coeq a^-1$ b^-1$ (hinverse _ _ p) (hinverse _ _ q)).
+  - nrefine (functor_ab_coeq_compose _ _ _ _ _ _ _ _
+      $@ functor2_ab_coeq _ _ _ _ _ $@ functor_ab_coeq_id _ _).
+    rapply cate_isretr.
+  - nrefine (functor_ab_coeq_compose _ _ _ _ _ _ _ _
+      $@ functor2_ab_coeq _ _ _ _ _ $@ functor_ab_coeq_id _ _).
+    rapply cate_issect.
+Defined.
+
 (** ** The bifunctor [ab_hom] *)
 
 Global Instance is0functor_ab_hom01 `{Funext} {A : Group^op}
@@ -63,11 +185,43 @@ Proof.
   by apply equiv_path_grouphomomorphism.
 Defined.
 
-Global Instance isbifunctor_ab_hom `{Funext}
-  : IsBifunctor (ab_hom : Group^op -> AbGroup -> AbGroup).
+Global Instance is1functor_ab_hom01 `{Funext} {A : Group^op}
+  : Is1Functor (ab_hom A).
+Proof.
+  nrapply Build_Is1Functor.
+  - intros B B' f g p phi.
+    apply equiv_path_grouphomomorphism; intro a; cbn.
+    exact (p (phi a)).
+  - intros B phi.
+    by apply equiv_path_grouphomomorphism.
+  - intros B C D f g phi.
+    by apply equiv_path_grouphomomorphism.
+Defined.
+
+Global Instance is1functor_ab_hom10 `{Funext} {B : AbGroup@{u}}
+  : Is1Functor (flip (ab_hom : Group^op -> AbGroup -> AbGroup) B).
+Proof.
+  nrapply Build_Is1Functor.
+  - intros A A' f g p phi.
+    apply equiv_path_grouphomomorphism; intro a; cbn.
+    exact (ap phi (p a)).
+  - intros A phi.
+    by apply equiv_path_grouphomomorphism.
+  - intros A C D f g phi.
+    by apply equiv_path_grouphomomorphism.
+Defined.
+
+Global Instance is0bifunctor_ab_hom `{Funext}
+  : Is0Bifunctor (ab_hom : Group^op -> AbGroup -> AbGroup).
+Proof.
+  rapply Build_Is0Bifunctor''.
+Defined.
+
+Global Instance is1bifunctor_ab_hom `{Funext}
+  : Is1Bifunctor (ab_hom : Group^op -> AbGroup -> AbGroup).
 Proof.
-  snrapply Build_IsBifunctor.
-  1-2: exact _.
+  nrapply Build_Is1Bifunctor''.
+  1,2: exact _.
   intros A A' f B B' g phi; cbn.
   by apply equiv_path_grouphomomorphism.
 Defined.
diff --git a/theories/Algebra/AbGroups/AbPushout.v b/theories/Algebra/AbGroups/AbPushout.v
index 5af7dd66b52..bcc5624a86b 100644
--- a/theories/Algebra/AbGroups/AbPushout.v
+++ b/theories/Algebra/AbGroups/AbPushout.v
@@ -1,4 +1,4 @@
-Require Import Basics Types Truncations.Core Modalities.ReflectiveSubuniverse.
+Require Import Basics Types Truncations.Core.
 Require Import WildCat.Core HSet.
 Require Export Algebra.Groups.Image Algebra.Groups.QuotientGroup.
 Require Import AbGroups.AbelianGroup AbGroups.Biproduct.
@@ -28,7 +28,7 @@ Proof.
   - intros [x y] q; strip_truncations; simpl.
     destruct q as [a q]. cbn in q.
     refine (ap (uncurry (fun x y => b x + c y)) q^ @ _).
-    unfold uncurry; cbn.
+    cbn.
     refine (ap011 sg_op (preserves_negate _) (p a)^ @ _).
     exact (left_inverse _).
 Defined.
@@ -71,7 +71,7 @@ Proof.
   srapply path_sigma_hprop.
   refine (grp_quotient_rec_beta _ Y _ _ @ _).
   apply equiv_path_grouphomomorphism; intro bc.
-  exact (ab_biprod_rec_beta' (phi $o grp_quotient_map) bc).
+  exact (ab_biprod_rec_eta (phi $o grp_quotient_map) bc).
 Defined.
 
 (** Restricting [ab_pushout_rec] along [ab_pushout_inl] recovers the left inducing map. *)
diff --git a/theories/Algebra/AbGroups/AbelianGroup.v b/theories/Algebra/AbGroups/AbelianGroup.v
index 485e69938e9..0e84f177736 100644
--- a/theories/Algebra/AbGroups/AbelianGroup.v
+++ b/theories/Algebra/AbGroups/AbelianGroup.v
@@ -1,5 +1,6 @@
 Require Import Basics Types.
-Require Export Classes.interfaces.canonical_names (Zero, zero).
+Require Import Spaces.Nat.Core Spaces.Int.
+Require Export Classes.interfaces.canonical_names (Zero, zero, Plus).
 Require Export Classes.interfaces.abstract_algebra (IsAbGroup(..), abgroup_group, abgroup_commutative).
 Require Export Algebra.Groups.Group.
 Require Export Algebra.Groups.Subgroup.
@@ -28,8 +29,43 @@ Proof.
   split; exact _.
 Defined.
 
+(** Easier way to build abelian groups without redundant information. *)
+Definition Build_AbGroup' (G : Type)
+  `{Zero G, Negate G, Plus G, IsHSet G}
+  (comm : Commutative (A:=G) (+))
+  (assoc : Associative (A:=G) (+))
+  (unit_l : LeftIdentity (A:=G) (+) 0)
+  (inv_l : LeftInverse (A:=G) (+) (-) 0)
+  : AbGroup.
+Proof.
+  snrapply Build_AbGroup.
+  - (* TODO: introduce smart constructor for [Build_Group] *)
+    rapply (Build_Group G).
+    repeat split; only 1-3, 5: exact _.
+    + intros x.
+      lhs nrapply comm.
+      exact (unit_l x).
+    + intros x.
+      lhs nrapply comm.
+      exact (inv_l x).
+  - exact comm.
+Defined.
+
 Definition issig_abgroup : _ <~> AbGroup := ltac:(issig).
 
+Global Instance zero_abgroup (A : AbGroup) : Zero A := group_unit.
+Global Instance plus_abgroup (A : AbGroup) : Plus A := group_sgop.
+Global Instance negate_abgroup (A : AbGroup) : Negate A := group_inverse.
+
+Definition ab_comm {A : AbGroup} (x y : A) : x + y = y + x
+  := commutativity x y.
+
+Definition ab_neg_op {A : AbGroup} (x y : A) : - (x + y) = -x - y.
+Proof.
+  lhs nrapply grp_inv_op.
+  apply ab_comm.
+Defined.
+
 (** ** Paths between abelian groups *)
 
 Definition equiv_path_abgroup `{Univalence} {A B : AbGroup@{u}}
@@ -57,14 +93,17 @@ Proof.
   cbn. apply commutativity.
 Defined.
 
+(** Given any subgroup of an abelian group, we can coerce it to an abelian group. Note that Coq complains this coercion doesn't satisfy the uniform-inheritance condition, but in practice it works and doesn't cause any issue, so we ignore it. *)
+Definition abgroup_subgroup (G : AbGroup) : Subgroup G -> AbGroup
+  := fun H => Build_AbGroup H _.
+#[warnings="-uniform-inheritance"]
+Coercion abgroup_subgroup : Subgroup >-> AbGroup.
+
 Global Instance isnormal_ab_subgroup (G : AbGroup) (H : Subgroup G)
   : IsNormalSubgroup H.
 Proof.
-  intros x y; unfold in_cosetL, in_cosetR.
-  refine (_ oE equiv_subgroup_inverse _ _).
-  rewrite negate_sg_op.
-  rewrite negate_involutive.
-  by rewrite (commutativity (-y) x).
+  intros x y h.
+  by rewrite ab_comm.
 Defined.
 
 (** ** Quotients of abelian groups *)
@@ -74,11 +113,7 @@ Global Instance isabgroup_quotient (G : AbGroup) (H : Subgroup G)
 Proof.
   nrapply Build_IsAbGroup.
   1: exact _.
-  intro x.
-  srapply Quotient_ind_hprop.
-  intro y; revert x.
-  srapply Quotient_ind_hprop.
-  intro x.
+  srapply Quotient_ind2_hprop; intros x y.
   apply (ap (class_of _)).
   apply commutativity.
 Defined.
@@ -86,6 +121,8 @@ Defined.
 Definition QuotientAbGroup (G : AbGroup) (H : Subgroup G) : AbGroup
   := (Build_AbGroup (QuotientGroup' G H (isnormal_ab_subgroup G H)) _).
 
+Arguments QuotientAbGroup G H : simpl never.
+
 Definition quotient_abgroup_rec {G : AbGroup}
   (N : Subgroup G) (H : AbGroup)
   (f : GroupHomomorphism G H) (h : forall n : G, N n -> f n = mon_unit)
@@ -138,23 +175,8 @@ Defined.
 (** AbGroup is a pointed category *)
 Global Instance ispointedcat_abgroup : IsPointedCat AbGroup.
 Proof.
-  snrapply Build_IsPointedCat.
-  1: exact abgroup_trivial.
-  { intro A.
-    snrefine (Build_GroupHomomorphism (fun _ => mon_unit); _).
-    1: exact _.
-    { intros [] [].
-      symmetry.
-      apply left_identity. }
-    intros g []; cbn.
-    exact (grp_homo_unit g)^. }
-  intro A.
-  snrefine (Build_GroupHomomorphism (fun _ => mon_unit); _).
-  1: exact _.
-  { intros x y; symmetry.
-    apply left_identity. }
-  intros g x; cbn.
-  apply path_unit.
+  apply Build_IsPointedCat with abgroup_trivial.
+  all: intro A; apply ispointedcat_group.
 Defined.
 
 (** Image of group homomorphisms between abelian groups *)
@@ -229,27 +251,20 @@ Proof.
     1-2: exact negate_involutive.
 Defined.
 
-(** Multiplication by [n : nat] defines an endomorphism of any abelian group [A]. *)
-Definition ab_mul_nat {A : AbGroup} (n : nat) : GroupHomomorphism A A.
+(** Multiplication by [n : Int] defines an endomorphism of any abelian group [A]. *)
+Definition ab_mul {A : AbGroup} (n : Int) : GroupHomomorphism A A.
 Proof.
   snrapply Build_GroupHomomorphism.
   1: exact (fun a => grp_pow a n).
   intros a b.
-  induction n; cbn.
-  1: exact (grp_unit_l _)^.
-  refine (_ @ associativity _ _ _).
-  refine (_ @ ap _ (associativity _ _ _)^).
-  rewrite (commutativity (grp_pow a n) b).
-  refine (_ @ ap _ (associativity _ _ _)).
-  refine (_ @ (associativity _ _ _)^).
-  apply grp_cancelL.
-  assumption.
+  apply grp_pow_mul, ab_comm.
 Defined.
 
-Definition ab_mul_nat_homo {A B : AbGroup}
-  (f : GroupHomomorphism A B) (n : nat)
-  : f o ab_mul_nat n == ab_mul_nat n o f
-  := grp_pow_homo f n.
+(** [ab_mul n] is natural. *)
+Definition ab_mul_natural {A B : AbGroup}
+  (f : GroupHomomorphism A B) (n : Int)
+  : f o ab_mul n == ab_mul n o f
+  := grp_pow_natural f n.
 
 (** The image of an inclusion is a normal subgroup. *)
 Definition ab_image_embedding {A B : AbGroup} (f : A $-> B) `{IsEmbedding f} : NormalSubgroup B
@@ -275,3 +290,73 @@ Proof.
   induction q.
   exact (p g).
 Defined.
+
+(** ** Finite Sums *)
+
+(** Indexed finite sum of abelian group elements. *)
+Definition ab_sum {A : AbGroup} (n : nat) (f : forall k, (k < n)%nat -> A) : A.
+Proof.
+  induction n as [|n IHn].
+  - exact zero.
+  - refine (f n _ + IHn _).
+    intros k Hk.
+    exact (f k _).
+Defined.
+
+(** If the function is constant in the range of a finite sum then the sum is equal to the constant times [n]. This is a group power in the underlying group. *)
+Definition ab_sum_const {A : AbGroup} (n : nat) (a : A)
+  (f : forall k, (k < n)%nat -> A) (p : forall k Hk, f k Hk = a)
+  : ab_sum n f = ab_mul n a.
+Proof.
+  induction n as [|n IHn] in f, p |- *.
+  - reflexivity.
+  - rhs_V nrapply (ap@{Set _} _ (int_nat_succ n)).
+    rhs nrapply grp_pow_succ.
+    simpl. f_ap.
+    apply IHn.
+    intros. apply p.
+Defined.
+
+(** If the function is zero in the range of a finite sum then the sum is zero. *)
+Definition ab_sum_zero {A : AbGroup} (n : nat)
+  (f : forall k, (k < n)%nat -> A) (p : forall k Hk, f k Hk = 0)
+  : ab_sum n f = 0.
+Proof.
+  lhs nrapply (ab_sum_const _ 0 f p).
+  apply grp_pow_unit.
+Defined.
+
+(** Finite sums distribute over addition. *)
+Definition ab_sum_plus {A : AbGroup} (n : nat) (f g : forall k, (k < n)%nat -> A)
+  : ab_sum n (fun k Hk => f k Hk + g k Hk)
+    = ab_sum n (fun k Hk => f k Hk) + ab_sum n (fun k Hk => g k Hk).
+Proof.
+  induction n as [|n IHn].
+  1: by rewrite grp_unit_l.
+  simpl.
+  rewrite <- !grp_assoc; f_ap.
+  rewrite IHn, ab_comm, <- grp_assoc; f_ap.
+  by rewrite ab_comm.
+Defined.
+
+(** Double finite sums commute. *)
+Definition ab_sum_sum {A : AbGroup} (m n : nat)
+  (f : forall i j, (i < m)%nat -> (j < n)%nat -> A)
+  : ab_sum m (fun i Hi => ab_sum n (fun j Hj => f i j Hi Hj))
+   = ab_sum n (fun j Hj => ab_sum m (fun i Hi => f i j Hi Hj)).
+Proof.
+  induction n as [|n IHn] in m, f |- *.
+  1: by nrapply ab_sum_zero.
+  lhs nrapply ab_sum_plus; cbn; f_ap.
+Defined.
+
+(** Finite sums are equal if the functions are equal in the range. *)
+Definition path_ab_sum {A : AbGroup} {n : nat} {f g : forall k, (k < n)%nat -> A}
+  (p : forall k Hk, f k Hk = g k Hk)
+  : ab_sum n f = ab_sum n g.
+Proof.
+  induction n as [|n IHn].
+  1: reflexivity.
+  cbn; f_ap.
+  by apply IHn.
+Defined.
diff --git a/theories/Algebra/AbGroups/Abelianization.v b/theories/Algebra/AbGroups/Abelianization.v
index 990449537c2..cb48c8cd547 100644
--- a/theories/Algebra/AbGroups/Abelianization.v
+++ b/theories/Algebra/AbGroups/Abelianization.v
@@ -1,7 +1,6 @@
 Require Import Basics Types Truncations.Core.
 Require Import Cubical WildCat.
 Require Import Colimits.Coeq.
-Require Import Algebra.Groups.Group.
 Require Import Algebra.AbGroups.AbelianGroup.
 Require Import Modalities.ReflectiveSubuniverse.
 
@@ -24,6 +23,28 @@ Class IsAbelianization {G : Group} (G_ab : AbGroup)
       IsSurjInj (group_precomp A eta).
 Global Existing Instance issurjinj_isabel.
 
+Definition isequiv_group_precomp_isabelianization `{Funext}
+  {G : Group} {G_ab : AbGroup} (eta : GroupHomomorphism G G_ab)
+  `{!IsAbelianization G_ab eta} (A : AbGroup)
+  : IsEquiv (group_precomp A eta).
+Proof.
+  snrapply isequiv_adjointify.
+  - intros g.
+    rapply (surjinj_inv (group_precomp A eta) g).
+  - intros f.
+    snrapply equiv_path_grouphomomorphism.
+    exact (eisretr0gpd_inv (group_precomp A eta) f).
+  - intros f.
+    snrapply equiv_path_grouphomomorphism.
+    exact (eissect0gpd_inv (group_precomp A eta) f).
+Defined.
+
+Definition equiv_group_precomp_isabelianization `{Funext}
+  {G : Group} {G_ab : AbGroup} (eta : GroupHomomorphism G G_ab)
+  `{!IsAbelianization G_ab eta} (A : AbGroup)
+  : (G_ab $-> A) <~> (G $-> A)
+  := Build_Equiv _ _ _ (isequiv_group_precomp_isabelianization eta A).
+
 (** Here we define abelianization as a HIT. Specifically as a set-coequalizer of the following two maps: (a, b, c) |-> a (b c) and (a, b, c) |-> a (c b).
 
 From this we can show that Abel G is an abelian group.
@@ -31,10 +52,10 @@ From this we can show that Abel G is an abelian group.
 In fact this models the following HIT:
 
 HIT Abel (G : Group) := 
- | ab : G -> Abel G
- | ab_comm : forall x y z, ab (x * (y * z)) = ab (x * (z * y)).
+ | abel_in : G -> Abel G
+ | abel_in_comm : forall x y z, abel_in (x * (y * z)) = abel_in (x * (z * y)).
 
-We also derive ab and ab_comm from our coequalizer definition, and even prove the induction and computation rules for this HIT.
+We also derive [abel_in] and [abel_in_comm] from our coequalizer definition, and even prove the induction and computation rules for this HIT.
 
 This HIT was suggested by Dan Christensen.
 *)
@@ -59,15 +80,15 @@ Section Abel.
       (uncurry2 (fun a b c : G => a * (c * b)))).
 
   (** We have a natural map from G to Abel G. *)
-  Definition ab : G -> Abel.
+  Definition abel_in : G -> Abel.
   Proof.
     intro g.
     apply tr, coeq, g.
   Defined.
 
   (** This map satisfies the condition ab_comm. *)
-  Definition ab_comm a b c
-    : ab (a * (b * c)) = ab (a * (c * b)).
+  Definition abel_in_comm a b c
+    : abel_in (a * (b * c)) = abel_in (a * (c * b)).
   Proof.
     apply (ap tr).
     exact (cglue (a, b, c)).
@@ -78,8 +99,8 @@ Section Abel.
 
   (** We can derive the induction principle from the ones for truncation and the coequalizer. *)
   Definition Abel_ind (P : Abel -> Type) `{forall x, IsHSet (P x)} 
-    (a : forall x, P (ab x)) (c : forall x y z, DPath P (ab_comm x y z)
-      (a (x * (y * z))) (a (x * (z * y))))
+    (a : forall x, P (abel_in x))
+    (c : forall x y z, DPath P (abel_in_comm x y z) (a (x * (y * z))) (a (x * (z * y))))
     : forall (x : Abel), P x.
   Proof.
     srapply Trunc_ind.
@@ -87,24 +108,31 @@ Section Abel.
     1: apply a.
     intros [[x y] z].
     refine (transport_compose _ _ _ _ @ _).
-    srapply dp_path_transport^-1%equiv.
     apply c.
   Defined.
 
-  (** The computation rule can also be proven. *)
-  Definition Abel_ind_beta_ab_comm (P : Abel -> Type)
-    `{forall x, IsHSet (P x)}(a : forall x, P (ab x))
-    (c : forall x y z, DPath P (ab_comm x y z)
-      (a (x * (y * z))) (a (x * (z * y))))
-    (x y z : G) : dp_apD (Abel_ind P a c) (ab_comm x y z) = c x y z.
+  (** The computation rule on point constructors holds definitionally. *)
+  Definition Abel_ind_beta_abel_in (P : Abel -> Type) `{forall x, IsHSet (P x)}
+    (a : forall x, P (abel_in x))
+    (c : forall x y z, DPath P (abel_in_comm x y z) (a (x * (y * z))) (a (x * (z * y))))
+    (x : G)
+    : Abel_ind P a c (abel_in x) = a x
+    := idpath.
+
+  (** The computation rule on paths. *)
+  Definition Abel_ind_beta_abel_in_comm (P : Abel -> Type) `{forall x, IsHSet (P x)}
+    (a : forall x, P (abel_in x))
+    (c : forall x y z, DPath P (abel_in_comm x y z) (a (x * (y * z))) (a (x * (z * y))))
+    (x y z : G)
+    : apD (Abel_ind P a c) (abel_in_comm x y z) = c x y z.
   Proof.
-    apply dp_apD_path_transport.
     refine (apD_compose' tr _ _ @ ap _ _ @ concat_V_pp _ _).
     rapply Coeq_ind_beta_cglue.
   Defined.
 
   (** We also have a recursion princple. *)
-  Definition Abel_rec (P : Type) `{IsHSet P} (a : G -> P)
+  Definition Abel_rec (P : Type) `{IsHSet P}
+    (a : G -> P)
     (c : forall x y z, a (x * (y * z)) = a (x * (z * y)))
     : Abel -> P.
   Proof.
@@ -112,18 +140,20 @@ Section Abel.
     intros; apply dp_const, c.
   Defined.
 
-  (** Here is a simpler version of Abel_ind when our target is an HProp. This lets us discard all the higher paths. *)
+  (** Here is a simpler version of [Abel_ind] when our target is an [HProp]. This lets us discard all the higher paths. *)
   Definition Abel_ind_hprop (P : Abel -> Type) `{forall x, IsHProp (P x)} 
-    (a : forall x, P (ab x)) : forall (x : Abel), P x.
+    (a : forall x, P (abel_in x))
+    : forall (x : Abel), P x.
   Proof.
-    srapply (Abel_ind _ a).
-    intros; apply dp_path_transport.
-    apply path_ishprop.
+    srapply Trunc_ind.
+    srapply Coeq_ind_hprop.
+    exact a.
   Defined.
 
   (** And its recursion version. *)
   Definition Abel_rec_hprop (P : Type) `{IsHProp P}
-    (a : G -> P) : Abel -> P.
+    (a : G -> P)
+    : Abel -> P.
   Proof.
     apply (Abel_rec _ a).
     intros; apply path_ishprop.
@@ -134,9 +164,10 @@ End Abel.
 (** The [IsHProp] argument of [Abel_ind_hprop] can usually be found by typeclass resolution, but [srapply] is slow, so we use this tactic instead. *)
 Local Ltac Abel_ind_hprop x := snrapply Abel_ind_hprop; [exact _ | intro x].
 
-(** We make sure that G is implicit in the arguments of ab and ab_comm. *)
-Arguments ab {_}.
-Arguments ab_comm {_}.
+(** We make sure that G is implicit in the arguments of [abel_in
+ and [abel_in_comm]. *)
+Arguments abel_in {_}.
+Arguments abel_in_comm {_}.
 
 (** Now we can show that Abel G is in fact an abelian group. *)
 
@@ -145,7 +176,9 @@ Section AbelGroup.
   Context (G : Group).
 
   (** Firstly we derive the operation on Abel G. This is defined as follows:
-        ab x + ab y := ab (x y)
+      <<
+        abel_in x + abel_in y := abel_in (x * y)
+      >>
       But we need to also check that it preserves ab_comm in the appropriate way. *)
   Global Instance abel_sgop : SgOp (Abel G).
   Proof.
@@ -155,21 +188,21 @@ Section AbelGroup.
       revert a.
       srapply Abel_rec.
       { intro a.
-        exact (ab (a * b)). }
+        exact (abel_in (a * b)). }
       intros a c d; hnf.
       (* The pattern seems to be to alternate associativity and ab_comm. *)
       refine (ap _ (associativity _ _ _)^ @ _).
-      refine (ab_comm _ _ _ @ _).
+      refine (abel_in_comm _ _ _ @ _).
       refine (ap _ (associativity _ _ _) @ _).
-      refine (ab_comm _ _ _ @ _).
+      refine (abel_in_comm _ _ _ @ _).
       refine (ap _ (associativity _ _ _)^ @ _).
-      refine (ab_comm _ _ _ @ _).
+      refine (abel_in_comm _ _ _ @ _).
       refine (ap _ (associativity _ _ _)). }
     intros b c d.
     revert a.
     Abel_ind_hprop a; simpl.
     refine (ap _ (associativity _ _ _) @ _).
-    refine (ab_comm _ _ _ @ _).
+    refine (abel_in_comm _ _ _ @ _).
     refine (ap _ (associativity _ _ _)^).
   Defined.
 
@@ -187,7 +220,7 @@ Section AbelGroup.
   Global Instance abel_issemigroup : IsSemiGroup (Abel G) := {}.
 
   (** We define the unit as ab of the unit of G *)
-  Global Instance abel_mon_unit : MonUnit (Abel G) := ab mon_unit.
+  Global Instance abel_mon_unit : MonUnit (Abel G) := abel_in mon_unit.
 
   (** By using Abel_ind_hprop we can prove the left and right identity laws. *)
   Global Instance abel_leftidentity : LeftIdentity abel_sgop abel_mon_unit.
@@ -212,25 +245,30 @@ Section AbelGroup.
     Abel_ind_hprop y.
     revert x.
     Abel_ind_hprop x.
-    refine ((ap ab (left_identity _))^ @ _).
-    refine (_ @ (ap ab (left_identity _))).
-    apply ab_comm.
+    refine ((ap abel_in (left_identity _))^ @ _).
+    refine (_ @ (ap abel_in (left_identity _))).
+    apply abel_in_comm.
   Defined.
 
   (** Now we can define the negation. This is just
-        - (ab g) := (ab (g^-1))
+      <<
+        - (abel_in g) := abel_in (- g)
+      >>
       However when checking that it respects ab_comm we have to show the following:
-        ab (- z * - y * - x) = ab (- y * - z * - x)
-      there is no obvious way to do this, but we note that ab (x * y) is exactly the definition of ab x + ab y! Hence by commutativity we can show this. *)
+      <<
+        abel_in (- z * - y * - x) = abel_in (- y * - z * - x)
+      >>
+      there is no obvious way to do this, but we note that [abel_in (x * y)] is exactly the definition of [abel_in x + abel_in y]! Hence by commutativity we can show this. *)
   Global Instance abel_negate : Negate (Abel G).
   Proof.
     srapply Abel_rec.
     { intro g.
-      exact (ab (-g)). }
+      exact (abel_in (-g)). }
     intros x y z; cbn.
     rewrite ?negate_sg_op.
-    change (ab(- z) * ab(- y) * ab (- x) = ab (- y) * ab (- z) * ab(- x)).
-    by rewrite (commutativity (ab (-z)) (ab (-y))).
+    change (abel_in (- z) * abel_in (- y) * abel_in (- x)
+      = abel_in (- y) * abel_in (- z) * abel_in (- x)).
+    by rewrite (commutativity (abel_in (-z)) (abel_in (-y))).
   Defined.
 
   (** Again by Abel_ind_hprop and the corresponding laws for G we can prove the left and right inverse laws. *)
@@ -252,16 +290,16 @@ Section AbelGroup.
   (** And since the operation is commutative, an abelian group. *)
   Global Instance isabgroup_abel : IsAbGroup (Abel G) := {}.
 
-  (** By definition, the map ab is also a group homomorphism. *)
-  Global Instance issemigrouppreserving_ab : IsSemiGroupPreserving ab.
+  (** By definition, the map [abel_in] is also a group homomorphism. *)
+  Global Instance issemigrouppreserving_abel_in : IsSemiGroupPreserving abel_in.
   Proof.
     by unfold IsSemiGroupPreserving.
   Defined.
 
 End AbelGroup.
 
-(** We can easily prove that ab is a surjection. *)
-Global Instance issurj_ab {G : Group} : IsSurjection (@ab G).
+(** We can easily prove that [abel_in] is a surjection. *)
+Global Instance issurj_abel_in {G : Group} : IsSurjection (@abel_in G).
 Proof.
   apply BuildIsSurjection.
   Abel_ind_hprop x.
@@ -282,32 +320,35 @@ Proof.
   - exact _.
 Defined.
 
-(** The unit of this map is the map ab which typeclasses can pick up to be a homomorphism. We write it out explicitly here. *)
-Definition abel_unit (X : Group)
-  : GroupHomomorphism X (abel X).
+Arguments abel G : simpl never.
+
+(** The unit of this map is the map [abel_in] which typeclasses can pick up to be a homomorphism. We write it out explicitly here. *)
+Definition abel_unit {G : Group}
+  : G $-> (abel G)
+  := @Build_GroupHomomorphism G (abel G) abel_in _.
+
+Definition grp_homo_abel_rec {G : Group} {A : AbGroup} (f : G $-> A)
+  : abel G $-> A.
 Proof.
-  snrapply @Build_GroupHomomorphism.
-  + exact ab.
-  + exact _.
+  snrapply Build_GroupHomomorphism.
+  { srapply (Abel_rec _ _ f).
+    intros x y z.
+    nrapply grp_homo_op_agree; trivial.
+    refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^).
+    apply commutativity. }
+  intros y.
+  Abel_ind_hprop x; revert y.
+  Abel_ind_hprop y.
+  apply grp_homo_op.
 Defined.
 
 (** Finally we can prove that our construction abel is an abelianization. *)
 Global Instance isabelianization_abel {G : Group}
-  : IsAbelianization (abel G) (abel_unit G).
+  : IsAbelianization (abel G) abel_unit.
 Proof.
   intros A. constructor.
-  { intros h. srefine (_;_).
-    { snrapply @Build_GroupHomomorphism.
-      { srapply (Abel_rec _ _ h).
-        intros x y z.
-        refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^).
-        apply (ap (_ *.)).
-        refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^).
-        apply commutativity. }
-      intros y.
-      Abel_ind_hprop x; revert y.
-      Abel_ind_hprop y.
-      apply grp_homo_op. }
+  { intros h.
+    snrefine (grp_homo_abel_rec h; _).
     cbn. reflexivity. }
   intros g h p.
   Abel_ind_hprop x.
@@ -353,8 +394,8 @@ Global Instance issurj_isabelianization {G : Group}
   : IsAbelianization A eta -> IsSurjection eta.
 Proof.
   intros k.
-  pose (homotopic_isabelianization A (abel G) eta (abel_unit G)) as p.
-  refine (@cancelL_isequiv_conn_map _ _ _ _ _ _ _
+  pose (homotopic_isabelianization A (abel G) eta abel_unit) as p.
+  exact (@cancelL_isequiv_conn_map _ _ _ _ _ _ _
     (conn_map_homotopic _ _ _ p _)).
 Defined.
 
@@ -374,3 +415,27 @@ Proof.
   - exact _.
   - symmetry; apply homotopic_isabelianization.
 Defined.
+
+(** ** Functoriality *)
+
+Global Instance is0functor_abel : Is0Functor abel.
+Proof.
+  snrapply Build_Is0Functor.
+  intros A B f.
+  snrapply grp_homo_abel_rec.
+  exact (abel_unit $o f).
+Defined.
+
+Global Instance is1functor_abel : Is1Functor abel.
+Proof.
+  snrapply Build_Is1Functor.
+  - intros A B f g p.
+    unfold abel.
+    rapply Abel_ind_hprop.
+    intros x.
+    exact (ap abel_in (p x)).
+  - intros A.
+    by rapply Abel_ind_hprop.
+  - intros A B C f g.
+    by rapply Abel_ind_hprop.
+Defined.
diff --git a/theories/Algebra/AbGroups/Biproduct.v b/theories/Algebra/AbGroups/Biproduct.v
index 57737bb8ebb..8d4f7ca28ee 100644
--- a/theories/Algebra/AbGroups/Biproduct.v
+++ b/theories/Algebra/AbGroups/Biproduct.v
@@ -23,6 +23,46 @@ Definition ab_biprod_inr {A B : AbGroup} : B $-> ab_biprod A B := grp_prod_inr.
 Definition ab_biprod_pr1 {A B : AbGroup} : ab_biprod A B $-> A := grp_prod_pr1.
 Definition ab_biprod_pr2 {A B : AbGroup} : ab_biprod A B $-> B := grp_prod_pr2.
 
+Definition ab_biprod_ind {A B : AbGroup}
+  (P : ab_biprod A B -> Type)
+  (Hinl : forall a, P (ab_biprod_inl a))
+  (Hinr : forall b, P (ab_biprod_inr b))
+  (Hop : forall x y, P x -> P y -> P (x + y))
+  : forall x, P x.
+Proof.
+  intros [a b].
+  snrapply ((grp_prod_decompose a b)^ # _).
+  apply Hop.
+  - exact (Hinl a).
+  - exact (Hinr b).
+Defined.
+
+Definition ab_biprod_ind_homotopy {A B C : AbGroup}
+  {f g : ab_biprod A B $-> C}
+  (Hinl : f $o ab_biprod_inl $== g $o ab_biprod_inl)
+  (Hinr : f $o ab_biprod_inr $== g $o ab_biprod_inr)
+  : f $== g.
+Proof.
+  rapply ab_biprod_ind.
+  - exact Hinl.
+  - exact Hinr.
+  - intros x y p q.
+    lhs nrapply grp_homo_op.
+    rhs nrapply grp_homo_op.
+    f_ap.
+Defined.
+
+(* Maps out of biproducts are determined on the two inclusions. *)
+Definition equiv_ab_biprod_ind_homotopy `{Funext} {A B X : AbGroup} (phi psi : ab_biprod A B $-> X)
+  : (phi $o ab_biprod_inl == psi $o ab_biprod_inl)
+    * (phi $o ab_biprod_inr == psi $o ab_biprod_inr)
+  <~> phi == psi.
+Proof.
+  apply equiv_iff_hprop.
+  - exact (uncurry ab_biprod_ind_homotopy).
+  - exact (fun h => (fun a => h _, fun b => h _)).
+Defined.
+
 (** Recursion principle *)
 Proposition ab_biprod_rec {A B Y : AbGroup}
             (f : A $-> Y) (g : B $-> Y)
@@ -47,7 +87,7 @@ Proof.
   intros [f g]. exact (ab_biprod_rec f g).
 Defined.
 
-Proposition ab_biprod_rec_beta' {A B Y : AbGroup}
+Proposition ab_biprod_rec_eta {A B Y : AbGroup}
             (u : ab_biprod A B $-> Y)
   : ab_biprod_rec (u $o ab_biprod_inl) (u $o ab_biprod_inr) == u.
 Proof.
@@ -58,29 +98,19 @@ Proof.
   - exact (left_identity b).
 Defined.
 
-Proposition ab_biprod_rec_beta `{Funext} {A B Y : AbGroup}
-            (u : ab_biprod A B $-> Y)
-  : ab_biprod_rec (u $o ab_biprod_inl) (u $o ab_biprod_inr) = u.
-Proof.
-  apply equiv_path_grouphomomorphism.
-  exact (ab_biprod_rec_beta' u).
-Defined.
-
-Proposition ab_biprod_rec_inl_beta `{Funext} {A B Y : AbGroup}
+Proposition ab_biprod_rec_beta_inl {A B Y : AbGroup}
             (a : A $-> Y) (b : B $-> Y)
-  : (ab_biprod_rec a b) $o ab_biprod_inl = a.
+  : (ab_biprod_rec a b) $o ab_biprod_inl == a.
 Proof.
-  apply equiv_path_grouphomomorphism.
   intro x; simpl.
   rewrite (grp_homo_unit b).
   exact (right_identity (a x)).
 Defined.
 
-Proposition ab_biprod_rec_inr_beta `{Funext} {A B Y : AbGroup}
+Proposition ab_biprod_rec_beta_inr {A B Y : AbGroup}
             (a : A $-> Y) (b : B $-> Y)
-  : (ab_biprod_rec a b) $o ab_biprod_inr = b.
+  : (ab_biprod_rec a b) $o ab_biprod_inr == b.
 Proof.
-  apply equiv_path_grouphomomorphism.
   intro y; simpl.
   rewrite (grp_homo_unit a).
   exact (left_identity (b y)).
@@ -93,11 +123,14 @@ Proof.
   - intro phi.
     exact (phi $o ab_biprod_inl, phi $o ab_biprod_inr).
   - intro phi.
-    exact (ab_biprod_rec_beta phi).
+    apply equiv_path_grouphomomorphism.
+    exact (ab_biprod_rec_eta phi).
   - intros [a b].
     apply path_prod.
-    + apply ab_biprod_rec_inl_beta.
-    + apply ab_biprod_rec_inr_beta.
+    + apply equiv_path_grouphomomorphism.
+      apply ab_biprod_rec_beta_inl.
+    + apply equiv_path_grouphomomorphism.
+      apply ab_biprod_rec_beta_inr.
 Defined.
 
 (** Corecursion principle, inherited from Groups/Group.v. *)
@@ -105,10 +138,6 @@ Definition ab_biprod_corec {A B X : AbGroup} (f : X $-> A) (g : X $-> B)
   : X $-> ab_biprod A B
   := grp_prod_corec f g.
 
-Definition ab_corec_beta {X Y A B : AbGroup} (f : X $-> Y) (g0 : Y $-> A) (g1 : Y $-> B)
-  : ab_biprod_corec g0 g1 $o f $== ab_biprod_corec (g0 $o f) (g1 $o f)
-  := fun _ => idpath.
-
 (** *** Functoriality of [ab_biprod] *)
 
 Definition functor_ab_biprod {A A' B B' : AbGroup} (f : A $-> A') (g: B $-> B')
@@ -121,6 +150,25 @@ Definition ab_biprod_functor_beta {Z X Y A B : AbGroup} (f0 : Z $-> X) (f1 : Z $
                       $== ab_biprod_corec (g0 $o f0) (g1 $o f1)
   := fun _ => idpath.
 
+Global Instance is0bifunctor_ab_biprod : Is0Bifunctor ab_biprod.
+Proof.
+  srapply Build_Is0Bifunctor'.
+  snrapply Build_Is0Functor.
+  intros [A B] [A' B'] [f g].
+  exact (functor_ab_biprod f g).
+Defined.
+
+Global Instance is1bifunctor_ab_biprod : Is1Bifunctor ab_biprod.
+Proof.
+  snrapply Build_Is1Bifunctor'.
+  snrapply Build_Is1Functor.
+  - intros [A B] [A' B'] [f g] [f' g'] [p q] [a b].
+    snrapply equiv_path_prod.
+    exact (p a, q b).
+  - reflexivity.
+  - cbn; reflexivity.
+Defined.
+
 Definition isequiv_functor_ab_biprod {A A' B B' : AbGroup}
            (f : A $-> A') (g : B $-> B') `{IsEquiv _ _ f} `{IsEquiv _ _ g}
   : IsEquiv (functor_ab_biprod f g).
@@ -182,29 +230,6 @@ Defined.
 
 (** *** Lemmas for working with biproducts *)
 
-Lemma ab_biprod_decompose {B A : AbGroup} (a : A) (b : B)
-  : (a, b) = ((a, group_unit) : ab_biprod A B) + (group_unit, b).
-Proof.
-  apply path_prod; cbn.
-  - exact (right_identity _)^.
-  - exact (left_identity _)^.
-Defined.
-
-(* Maps out of biproducts are determined on the two inclusions. *)
-Lemma equiv_path_biprod_corec `{Funext} {A B X : AbGroup} (phi psi : ab_biprod A B $-> X)
-  : ((phi $o ab_biprod_inl == psi $o ab_biprod_inl) * (phi $o ab_biprod_inr == psi $o ab_biprod_inr))
-      <~> phi == psi.
-Proof.
-  apply equiv_iff_hprop.
-  - intros [h k].
-    intros [a b].
-    refine (ap phi (ab_biprod_decompose _ _) @ _ @ ap psi (ab_biprod_decompose _ _)^).
-    refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^).
-    exact (ap011 (+) (h a) (k b)).
-  - intro h.
-    exact (fun a => h _, fun b => h _).
-Defined.
-
 (** The swap isomorphism of the biproduct of two groups. *)
 Definition direct_sum_swap {A B : AbGroup}
   : ab_biprod A B $<~> ab_biprod B A.
diff --git a/theories/Algebra/AbGroups/Cyclic.v b/theories/Algebra/AbGroups/Cyclic.v
index c982b8c0378..0da63064488 100644
--- a/theories/Algebra/AbGroups/Cyclic.v
+++ b/theories/Algebra/AbGroups/Cyclic.v
@@ -1,76 +1,18 @@
-Require Import Basics Types WildCat.Core Truncations.Core
-  AbelianGroup AbHom Centralizer AbProjective
-  Groups.FreeGroup.
+Require Import Basics.Overture Basics.Tactics WildCat.Core AbelianGroup
+  AbGroups.Z Spaces.Int Groups.QuotientGroup.
 
 (** * Cyclic groups *)
 
-(** ** The free group on one generator *)
+(** The [n]-th cyclic group is the cokernel of [ab_mul n]. *)
+Definition cyclic (n : nat) : AbGroup
+  := ab_cokernel (ab_mul (A:=abgroup_Z) n).
 
-(** We can define the integers as the free group on one generator, which we denote [Z1] below. Results from Centralizer.v and Groups.FreeGroup let us show that [Z1] is abelian. *)
+Definition cyclic_in (n : nat) : abgroup_Z $-> cyclic n
+  := grp_quotient_map. 
 
-(** We define [Z] as the free group with a single generator. *)
-Definition Z1 := FreeGroup Unit.
-Definition Z1_gen : Z1 := freegroup_in tt. (* The generator *)
-
-(** The recursion principle of [Z1] and its computation rule. *)
-Definition Z1_rec {G : Group@{u}} (g : G) : Z1 $-> G
-  := FreeGroup_rec Unit G (unit_name g).
-
-Definition Z1_rec_beta {G : Group} (g : G) : Z1_rec g Z1_gen = g
-  := FreeGroup_rec_beta _ _ _.
-
-(* The free group [Z] on one generator is isomorphic to the subgroup of [Z] generated by the generator.  And such cyclic subgroups are known to be commutative, by [commutative_cyclic_subgroup]. *)
-Global Instance Z1_commutative `{Funext} : Commutative (@group_sgop Z1)
-  := commutative_iso_commutative iso_subgroup_incl_freegroupon.
-(* [Funext] is used in [isfreegroupon_freegroup], but there is a comment there saying that it can be removed.  If that is done, don't need it here either. A different proof of this result, directly using the construction of the free group, could probably also avoid [Funext]. *)
-
-Definition ab_Z1 `{Funext} : AbGroup
-  := Build_AbGroup Z1 _.
-
-(** The universal property of [ab_Z1]. *)
-Lemma equiv_Z1_hom@{u v | u < v} `{Funext} (A : AbGroup@{u})
-  : GroupIsomorphism (ab_hom@{u v} ab_Z1@{u v} A) A.
+Definition ab_mul_cyclic_in (n : nat) (x y : abgroup_Z)
+  : ab_mul y (cyclic_in n x) = cyclic_in n (y * x)%int.
 Proof.
-  snrapply Build_GroupIsomorphism'.
-  - refine (_ oE (equiv_freegroup_rec@{u u u v} A Unit)^-1).
-    symmetry. refine (Build_Equiv _ _ (fun a => unit_name a) _).
-  - intros f g. cbn. reflexivity.
+  lhs_V nrapply ab_mul_natural.
+  apply ap, abgroup_Z_ab_mul.
 Defined.
-
-Definition nat_to_Z1 : nat -> Z1
-  := fun n => grp_pow Z1_gen n.
-
-Definition Z1_mul_nat `{Funext} (n : nat) : ab_Z1 $-> ab_Z1
-  := Z1_rec (nat_to_Z1 n).
-
-Lemma Z1_mul_nat_beta {A : AbGroup} (a : A) (n : nat)
-  : Z1_rec a (nat_to_Z1 n) = ab_mul_nat n a.
-Proof.
-  induction n as [|n H].
-  1: easy.
-  refine (grp_pow_homo _ _ _ @ _); simpl.
-  by rewrite grp_unit_r.
-Defined.
-
-(** [ab_Z1] is projective. *)
-Global Instance ab_Z1_projective `{Funext}
-  : IsAbProjective ab_Z1.
-Proof.
-  intros A B p f H1.
-  pose proof (a := @center _ (H1 (f Z1_gen))).
-  strip_truncations.
-  snrefine (tr (Z1_rec a.1; _)).
-  cbn beta. apply ap10.
-  apply ap. (* of the coercion [grp_homo_map] *)
-  apply path_homomorphism_from_free_group.
-  simpl.
-  intros [].
-  refine (_ @ a.2).
-  exact (ap p (grp_unit_r _)).
-Defined.
-
-(** * Finite cyclic groups *)
-
-(** The [n]-th cyclic group is the cokernel of [Z1_mul_nat n]. *)
-Definition cyclic@{u v | u < v} `{Funext} (n : nat) : AbGroup@{u}
-  := ab_cokernel@{u v} (Z1_mul_nat n).
diff --git a/theories/Algebra/AbGroups/FreeAbelianGroup.v b/theories/Algebra/AbGroups/FreeAbelianGroup.v
new file mode 100644
index 00000000000..1d3558b7b79
--- /dev/null
+++ b/theories/Algebra/AbGroups/FreeAbelianGroup.v
@@ -0,0 +1,72 @@
+Require Import Basics.Overture Basics.Tactics Basics.Equivalences.
+Require Import Types.Sigma Types.Forall Types.Paths.
+Require Import WildCat.Core WildCat.EquivGpd WildCat.Universe.
+Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Abelianization.
+Require Import Algebra.Groups.FreeGroup.
+Require Import Spaces.List.Core.
+
+(** * Free Abelian Groups *)
+
+Definition FactorsThroughFreeAbGroup (S : Type) (F_S : AbGroup)
+  (i : S -> F_S) (A : AbGroup) (g : S -> A) : Type
+  := {f : F_S $-> A & f o i == g}.
+
+(** Universal property of a free abelian group on a set (type). *)
+Class IsFreeAbGroupOn (S : Type) (F_S : AbGroup) (i : S -> F_S)
+  := contr_isfreeabgroupon : forall (A : AbGroup) (g : S -> A),
+      Contr (FactorsThroughFreeAbGroup S F_S i A g).
+Global Existing Instance contr_isfreeabgroupon.
+
+(** A abelian group is free if there exists a generating type on which it is a free group (a basis). *)
+Class IsFreeAbGroup (F_S : AbGroup)
+  := isfreegroup : {S : _ & {i : _ & IsFreeAbGroupOn S F_S i}}.
+
+Global Instance isfreeabgroup_isfreeabgroupon (S : Type) (F_S : AbGroup) (i : S -> F_S)
+  {H : IsFreeAbGroupOn S F_S i}
+  : IsFreeAbGroup F_S
+  := (S; i; H).
+
+(** The abelianization of the free group on a set is the free abelian group. *)
+Definition FreeAbGroup (S : Type) : AbGroup
+  := abel (FreeGroup S).
+
+Arguments FreeAbGroup S : simpl never.
+
+Definition freeabgroup_in {S : Type} : S -> FreeAbGroup S
+  := abel_unit o freegroup_in.
+
+Definition FreeAbGroup_rec {S : Type} {A : AbGroup} (f : S -> A)
+  : FreeAbGroup S $-> A
+  := grp_homo_abel_rec (FreeGroup_rec _ _ f).
+
+Definition FreeAbGroup_rec_beta_in {S : Type} {A : AbGroup} (f : S -> A)
+  : FreeAbGroup_rec f o freeabgroup_in == f
+  := fun _ => idpath.
+
+(** The abelianization of a free group on a set is a free abelian group on that set. *)
+Global Instance isfreeabgroupon_isabelianization_isfreegroup `{Funext}
+  {S : Type} {G : Group} {A : AbGroup} (f : S -> G) (g : G $-> A)
+  {H1 : IsAbelianization A g} {H2 : IsFreeGroupOn S G f}
+  : IsFreeAbGroupOn S A (g o f).
+Proof.
+  unfold IsFreeAbGroupOn.
+  intros B h.
+  specialize (H2 B h).
+  revert H2.
+  unfold FactorsThroughFreeGroup, FactorsThroughFreeAbGroup.
+  snrapply contr_equiv'.
+  symmetry.
+  exact (equiv_functor_sigma_pb (equiv_group_precomp_isabelianization g B)).
+Defined.
+
+(** As a special case, the free abelian group is a free abelian group. *)
+Global Instance isfreeabgroup_freeabgroup `{Funext} (S : Type)
+  : IsFreeAbGroup (FreeAbGroup S).
+Proof.
+  exists S, freeabgroup_in.
+  srapply isfreeabgroupon_isabelianization_isfreegroup.
+Defined.
+
+(** Functoriality follows from the functoriality of [abel] and [FreeGroup]. *)
+Global Instance is0functor_freeabgroup : Is0Functor FreeAbGroup := _.
+Global Instance is1functor_freeabgroup : Is1Functor FreeAbGroup := _.
diff --git a/theories/Algebra/AbGroups/TensorProduct.v b/theories/Algebra/AbGroups/TensorProduct.v
new file mode 100644
index 00000000000..bb3c26d6a52
--- /dev/null
+++ b/theories/Algebra/AbGroups/TensorProduct.v
@@ -0,0 +1,858 @@
+Require Import Basics.Overture Basics.Tactics.
+Require Import Types.Forall Types.Sigma Types.Prod.
+Require Import WildCat.Core WildCat.Equiv WildCat.Monoidal WildCat.Bifunctor.
+Require Import WildCat.NatTrans.
+Require Import Algebra.Groups.Group Algebra.Groups.QuotientGroup.
+Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Biproduct.
+Require Import Algebra.AbGroups.AbHom Algebra.AbGroups.FreeAbelianGroup.
+Require Import Algebra.AbGroups.Abelianization Algebra Algebra.Groups.FreeGroup.
+Require Import Colimits.Quotient.
+Require Import Spaces.List.Core Spaces.Int.
+Require Import AbGroups.Z.
+Require Import Truncations.
+
+Local Open Scope mc_scope.
+Local Open Scope mc_add_scope.
+
+(** * The Tensor Product of Abelian Groups *)
+
+(** Various maps [A * B → C] from the cartesian product of two abelian groups to another abelian group are "biadditive" (also called "bilinear"), meaning that they are group homomorphisms when we fix the left or right argument.
+
+The tensor product of abelian groups is a construction that produces an abelian group [A ⊗ B] along with a biadditive map [A * B -> A ⊗ B] which is initial among biadditive maps from [A * B].  This means that any biadditive map [A * B → C] factors uniquely through the tensor product via a group homomorphism [A ⊗ B -> C].
+
+Biadditive functions appear in all sorts of contexts ranging from linear algebra to analysis. Therefore having a way to systematically study them is very useful. *)
+
+(** ** Construction *)
+
+(** We define the tensor product of abelian groups as a quotient of the free abelian group on pairs of elements of the two groups by the subgroup generated by the biadditive pairs. *)
+
+(** Here we define the subgroup of biadditive pairs in two steps. *)
+Definition family_biadditive_pairs {A B : AbGroup}
+  : FreeAbGroup (A * B) -> Type.
+Proof.
+  intros x.
+  refine ((exists (a1 a2 : A) (b : B), _) + exists (a : A) (b1 b2 : B), _)%type. 
+  - refine (- _ + (_ + _) = x).
+    1-3: apply freeabgroup_in.
+    + exact (a1 + a2, b).
+    + exact (a1, b).
+    + exact (a2, b).
+  - refine (- _ + (_ + _) = x).
+    1-3: apply freeabgroup_in.
+    + exact (a, b1 + b2).
+    + exact (a, b1).
+    + exact (a, b2).
+Defined.
+
+Definition subgroup_biadditive_pairs {A B : AbGroup}
+  : Subgroup (FreeAbGroup (A * B))
+  := subgroup_generated family_biadditive_pairs.
+
+(** The tensor product [ab_tensor_prod A B] of two abelian groups [A] and [B] is defined to be a quotient of the free abelian group on pairs of elements [A * B] by the subgroup of biadditive pairs. *)
+Definition ab_tensor_prod (A B : AbGroup) : AbGroup
+  := QuotientAbGroup (FreeAbGroup (A * B)) subgroup_biadditive_pairs.
+
+Arguments ab_tensor_prod A B : simpl never.
+
+(** The tensor product of [A] and [B] contains formal sums and differences of pairs of elements from [A] and [B]. We denote these pairs as "simple tensors" and name them [tensor]. *)
+Definition tensor {A B : AbGroup} : A -> B -> ab_tensor_prod A B
+  := fun a b => grp_quotient_map (freeabgroup_in (a, b)).
+
+(** ** Properties of tensors *)
+
+(** The characterizing property of simple tensors are that they are biadditive in their arguments. *)
+
+(** A [tensor] of a sum distributes over the sum on the left. *) 
+Definition tensor_dist_l {A B : AbGroup} (a : A) (b b' : B)
+  : tensor a (b + b') = tensor a b + tensor a b'.
+Proof.
+  apply qglue, tr.
+  apply sgt_in.
+  right.
+  by exists a, b, b'.
+Defined.
+
+(** A [tensor] of a sum distributes over the sum on the right. *)
+Definition tensor_dist_r {A B : AbGroup} (a a' : A) (b : B)
+  : tensor (a + a') b = tensor a b + tensor a' b.
+Proof.
+  apply qglue, tr.
+  apply sgt_in.
+  left.
+  by exists a, a', b.
+Defined.
+
+(** Tensoring on the left is a group homomorphism. *)
+Definition grp_homo_tensor_l {A B : AbGroup} (a : A)
+  : B $-> ab_tensor_prod A B.
+Proof.
+  snrapply Build_GroupHomomorphism.
+  - exact (fun b => tensor a b).
+  - intros b b'.
+    nrapply tensor_dist_l.
+Defined. 
+
+(** Tensoring on the right is a group homomorphism. *)
+Definition grp_homo_tensor_r {A B : AbGroup} (b : B)
+  : A $-> ab_tensor_prod A B.
+Proof.
+  snrapply Build_GroupHomomorphism.
+  - exact (fun a => tensor a b).
+  - intros a a'.
+    nrapply tensor_dist_r.
+Defined.
+
+(** Tensors preserve negation in the left argument. *)
+Definition tensor_neg_l {A B : AbGroup} (a : A) (b : B)
+  : tensor (-a) b = - tensor a b
+  := grp_homo_inv (grp_homo_tensor_r b) a.
+
+(** Tensors preserve negation in the right argument. *)
+Definition tensor_neg_r {A B : AbGroup} (a : A) (b : B)
+  : tensor a (-b) = - tensor a b
+  := grp_homo_inv (grp_homo_tensor_l a) b.
+
+(** Tensoring by zero on the left is zero. *)
+Definition tensor_zero_l {A B : AbGroup} (b : B)
+  : tensor (A:=A) 0 b = 0
+  := grp_homo_unit (grp_homo_tensor_r b).
+
+(** Tensoring by zero on the right is zero. *)
+Definition tensor_zero_r {A B : AbGroup} (a : A)
+  : tensor (B:=B) a 0 = 0
+  := grp_homo_unit (grp_homo_tensor_l a).
+
+(** The [tensor] map is biadditive and therefore can be written in a curried form using the internal abelian group hom. *)
+Definition grp_homo_tensor `{Funext} {A B : AbGroup}
+  : A $-> ab_hom B (ab_tensor_prod A B). 
+Proof.
+  snrapply Build_GroupHomomorphism.
+  - intros a.
+    snrapply Build_GroupHomomorphism.
+    + exact (tensor a).
+    + nrapply tensor_dist_l.
+  - intros a a'.
+    apply equiv_path_grouphomomorphism.
+    intros b.
+    nrapply tensor_dist_r.
+Defined.
+
+(** ** Induction principles *)
+
+(** Here we write down some induction principles to help us prove lemmas about the tensor product. Some of these are quite specialised but are patterns that appear often in practice. *) 
+
+(** Our main recursion principle states that in order to build a homomorphism out of the tensor product, it is sufficient to provide a map out of the direct product which is biadditive, that is, a map that preserves addition in each argument of the product. *)
+
+(** We separate out the proof of this part, so we can make it opaque. *)
+Definition ab_tensor_prod_rec_helper {A B C : AbGroup}
+  (f : A -> B -> C)
+  (l : forall a b b', f a (b + b') = f a b + f a b')
+  (r : forall a a' b, f (a + a') b = f a b + f a' b)
+  (x : FreeAbGroup (A * B)) (insg : subgroup_biadditive_pairs x)
+  : grp_homo_abel_rec (FreeGroup_rec (A * B) C (uncurry f)) x = mon_unit.
+Proof.
+  set (abel_rec := grp_homo_abel_rec (FreeGroup_rec (A * B) C (uncurry f))).
+  strip_truncations.
+  induction insg as [ x biad | | g h insg_g IHg insg_h IHh ].
+  - destruct biad as [ [ a [ a' [ b p ] ] ] | [ a [ b [ b' p ] ] ] ].
+    all: destruct p; simpl.
+    all: apply grp_moveL_M1^-1%equiv; symmetry.
+    1: apply r.
+    apply l.
+  - nrapply grp_homo_unit.
+  - rewrite grp_homo_op, grp_homo_inv.
+    apply grp_moveL_1M^-1.
+    exact (IHg @ IHh^).
+Defined.
+
+Opaque ab_tensor_prod_rec_helper.
+
+Definition ab_tensor_prod_rec {A B C : AbGroup}
+  (f : A -> B -> C)
+  (l : forall a b b', f a (b + b') = f a b + f a b')
+  (r : forall a a' b, f (a + a') b = f a b + f a' b) 
+  : ab_tensor_prod A B $-> C.
+Proof.
+  unfold ab_tensor_prod.
+  snrapply grp_quotient_rec.
+  - snrapply FreeAbGroup_rec.
+    exact (uncurry f).
+  - unfold normalsubgroup_subgroup.
+    apply ab_tensor_prod_rec_helper; assumption.
+Defined.
+
+(** A special case that arises. *)
+Definition ab_tensor_prod_rec' {A B C : AbGroup}
+  (f : A -> (B $-> C))
+  (l : forall a a' b, f (a + a') b = f a b + f a' b)
+  : ab_tensor_prod A B $-> C.
+Proof.
+  refine (ab_tensor_prod_rec f _ l).
+  intro a; apply grp_homo_op.
+Defined.
+
+(** We give an induction principle for an hprop-valued type family [P].  It may be surprising at first that we only require [P] to hold for the simple tensors [tensor a b] and be closed under addition.  It automatically follows that [P 0] holds (since [tensor 0 0 = 0]) and that [P] is closed under negation (since [tensor -a b = - tensor a b]). This induction principle says that the simple tensors generate the tensor product as a semigroup. *)
+Definition ab_tensor_prod_ind_hprop {A B : AbGroup}
+  (P : ab_tensor_prod A B -> Type)
+  {H : forall x, IsHProp (P x)}
+  (Hin : forall a b, P (tensor a b))
+  (Hop : forall x y, P x -> P y -> P (x + y))
+  : forall x, P x.
+Proof.
+  unfold ab_tensor_prod.
+  srapply grp_quotient_ind_hprop.
+  srapply Abel_ind_hprop; cbn beta.
+  set (tensor_in := grp_quotient_map $o abel_unit : FreeGroup (A * B) $-> ab_tensor_prod A B).
+  change (forall x, P (tensor_in x)).
+  srapply FreeGroup_ind_hprop'; intros w; cbn beta.
+  induction w.
+  - (* The goal here is [P 0], so we use [Hin 0 0 : P (tensor 0 0)]. *)
+    exact (transport P (tensor_zero_l 0) (Hin 0 0)).
+  - change (P (tensor_in (freegroup_eta [a]%list + freegroup_eta w))).
+    (* This [rewrite] is [reflexivity], but the [Defined] is slow if [change] is used instead. *)
+    rewrite grp_homo_op.
+    destruct a as [[a b]|[a b]].
+    + change (P (tensor_in (freegroup_in (a, b)) + tensor_in (freegroup_eta w))).
+      apply Hop; trivial.
+      apply Hin.
+    + change (P (tensor_in (- freegroup_in (a, b)) + tensor_in (freegroup_eta w))).
+      (* This [rewrite] is also reflexivity. *)
+      rewrite grp_homo_inv.
+      apply Hop; trivial.
+      rewrite <- tensor_neg_l.
+      apply Hin.
+Defined.
+
+(** As a commonly occuring special case of the above induction principle, we have the case when the predicate in question is showing that two group homomorphisms out of the tensor product are homotopic. In order to do this, it suffices to show it only for simple tensors. The homotopy is closed under addition, so we don't need to hypothesise anything else. *)
+Definition ab_tensor_prod_ind_homotopy {A B G : AbGroup}
+  {f f' : ab_tensor_prod A B $-> G}
+  (H : forall a b, f (tensor a b) = f' (tensor a b))
+  : f $== f'.
+Proof.
+  nrapply ab_tensor_prod_ind_hprop.
+  - exact _.
+  - exact H.
+  - intros x y; apply grp_homo_op_agree.
+Defined.
+
+(** As an even more specialised case, we occasionally have the second homomorphism being a sum of abelian group homomorphisms. In those cases, it is easier to use this specialised lemma. *)
+Definition ab_tensor_prod_ind_homotopy_plus {A B G : AbGroup}
+  {f f' f'' : ab_tensor_prod A B $-> G}
+  (H : forall a b, f (tensor a b) = f' (tensor a b) + f'' (tensor a b))
+  : forall x, f x = f' x + f'' x
+  := ab_tensor_prod_ind_homotopy (f':=ab_homo_add f' f'') H.
+
+(** Here we give an induction principle for a triple tensor, a.k.a a dependent trilinear function. *)
+Definition ab_tensor_prod_ind_hprop_triple {A B C : AbGroup}
+  (P : ab_tensor_prod A (ab_tensor_prod B C) -> Type)
+  (H : forall x, IsHProp (P x))
+  (Hin : forall a b c, P (tensor a (tensor b c)))
+  (Hop : forall x y, P x -> P y -> P (x + y))
+  : forall x, P x.
+Proof.
+  rapply (ab_tensor_prod_ind_hprop P).
+  - intros a.
+    rapply (ab_tensor_prod_ind_hprop (fun x => P (tensor _ x))).
+    + nrapply Hin.
+    + intros x y Hx Hy.
+      rewrite tensor_dist_l.
+      by apply Hop.
+  - exact Hop.
+Defined.
+
+(** Similar to before, we specialise the triple tensor induction principle for proving homotopies of trilinear/triadditive functions. *)
+Definition ab_tensor_prod_ind_homotopy_triple {A B C G : AbGroup}
+  {f f' : ab_tensor_prod A (ab_tensor_prod B C) $-> G}
+  (H : forall a b c, f (tensor a (tensor b c)) = f' (tensor a (tensor b c)))
+  : f $== f'.
+Proof.
+  nrapply ab_tensor_prod_ind_hprop_triple.
+  - exact _.
+  - exact H.
+  - intros x y; apply grp_homo_op_agree.
+Defined.
+
+(** As explained for the biadditive and triadditive cases, we also derive an induction principle for quadruple tensors giving us dependent quadrilinear maps. *)
+Definition ab_tensor_prod_ind_hprop_quad {A B C D : AbGroup}
+  (P : ab_tensor_prod A (ab_tensor_prod B (ab_tensor_prod C D)) -> Type)
+  (H : forall x, IsHProp (P x))
+  (Hin : forall a b c d, P (tensor a (tensor b (tensor c d))))
+  (Hop : forall x y, P x -> P y -> P (x + y))
+  : forall x, P x.
+Proof.
+  rapply (ab_tensor_prod_ind_hprop P).
+  - intros a.
+    nrapply (ab_tensor_prod_ind_hprop_triple (fun x => P (tensor _ x))).
+    + intro x; apply H.
+    + nrapply Hin.
+    + intros x y Hx Hy.
+      rewrite tensor_dist_l.
+      by apply Hop.
+  - exact Hop.
+Defined.
+
+(** To construct a homotopy between quadrilinear maps we need only check equality for the quadruple simple tensors. *)
+Definition ab_tensor_prod_ind_homotopy_quad {A B C D G : AbGroup}
+  {f f' : ab_tensor_prod A (ab_tensor_prod B (ab_tensor_prod C D)) $-> G}
+  (H : forall a b c d, f (tensor a (tensor b (tensor c d)))
+    = f' (tensor a (tensor b (tensor c d))))
+  : f $== f'.
+Proof.
+  nrapply (ab_tensor_prod_ind_hprop_quad (fun _ => _)).
+  - exact _.
+  - exact H.
+  - intros x y; apply grp_homo_op_agree.
+Defined.
+
+(** ** Universal Property of the Tensor Product *)
+
+(** A function of two variables is biadditive if it preserves the operation in each variable. *)
+Class IsBiadditive {A B C : Type} `{SgOp A, SgOp B, SgOp C} (f : A -> B -> C) := {
+  isbiadditive_l :: forall b, IsSemiGroupPreserving (flip f b);
+  isbiadditive_r :: forall a, IsSemiGroupPreserving (f a);  
+}.
+
+Definition issig_IsBiadditive {A B C : Type} `{SgOp A, SgOp B, SgOp C}
+  (f : A -> B -> C)
+  : _ <~> IsBiadditive f
+  := ltac:(issig).
+
+(** The truncation level of the [IsBiadditive f] predicate is determined by the truncation level of the codomain. This will almost always be a hset. *)
+Global Instance istrunc_isbiadditive `{Funext}
+  {A B C : Type} `{SgOp A, SgOp B, SgOp C}
+  (f : A -> B -> C) n `{IsTrunc n.+1 C}
+  : IsTrunc n (IsBiadditive f).
+Proof.
+  nrapply istrunc_equiv_istrunc.
+  1: rapply issig_IsBiadditive.
+  unfold IsSemiGroupPreserving.
+  exact _.
+Defined.
+
+(** The simple tensor map is biadditive. *)
+Global Instance isbiadditive_tensor (A B : AbGroup)
+  : IsBiadditive (@tensor A B) := {|
+  isbiadditive_l := fun b a a' => tensor_dist_r a a' b;
+  isbiadditive_r := tensor_dist_l;
+|}.
+
+(** The type of biadditive maps. *)
+Record Biadditive (A B C : Type) `{SgOp A, SgOp B, SgOp C} := {
+  biadditive_fun :> A -> B -> C;
+  biadditive_isbiadditive :: IsBiadditive biadditive_fun;
+}.
+
+Definition issig_Biadditive {A B C : Type} `{SgOp A, SgOp B, SgOp C}
+  : _ <~> Biadditive A B C
+  := ltac:(issig).
+
+Definition biadditive_ab_tensor_prod {A B C : AbGroup}
+  : (ab_tensor_prod A B $-> C) -> Biadditive A B C.
+Proof.
+  intros f.
+  exists (fun x y => f (tensor x y)).
+  snrapply Build_IsBiadditive.
+  - intros b a a'; simpl.
+    lhs nrapply (ap f).
+    1: nrapply tensor_dist_r.
+    nrapply grp_homo_op.
+  - intros a a' b; simpl.
+    lhs nrapply (ap f).
+    1: nrapply tensor_dist_l.
+    nrapply grp_homo_op.
+Defined.
+
+(** The universal property of the tensor product is that biadditive maps between abelian groups are in one-to-one corresondance with maps out of the tensor product. In this sense, the tensor product is the most perfect object describing biadditive maps between two abelian groups. *)
+Definition equiv_ab_tensor_prod_rec `{Funext} (A B C : AbGroup)
+  : Biadditive A B C <~> (ab_tensor_prod A B $-> C).
+Proof.
+  snrapply equiv_adjointify.
+  - intros [f [l r]].
+    exact (ab_tensor_prod_rec f r (fun a a' b => l b a a')).
+  - snrapply biadditive_ab_tensor_prod.
+  - intros f.
+    snrapply equiv_path_grouphomomorphism.
+    snrapply ab_tensor_prod_ind_homotopy.
+    intros a b; simpl.
+    reflexivity.
+  - intros [f [l r]].
+    snrapply (equiv_ap_inv' issig_Biadditive).
+    rapply path_sigma_hprop; simpl.
+    reflexivity.
+Defined.
+
+(** ** Functoriality of the Tensor Product *)
+
+(** The tensor product produces a bifunctor and we will later show that it gives a symmetric monoidal structure on the category of abelian groups. *)
+
+(** Given a pair of maps, we can produce a homomorphism between the pairwise tensor products of the domains and codomains. *) 
+Definition functor_ab_tensor_prod {A B A' B' : AbGroup}
+  (f : A $-> A') (g : B $-> B')
+  : ab_tensor_prod A B $-> ab_tensor_prod A' B'.
+Proof.
+  snrapply ab_tensor_prod_rec'.
+  - intro a.
+    exact (grp_homo_tensor_l (f a) $o g).
+  - intros a a' b; hnf.
+    rewrite grp_homo_op.
+    nrapply tensor_dist_r.
+Defined.
+
+(** 2-functoriality of the tensor product. *)
+Definition functor2_ab_tensor_prod {A B A' B' : AbGroup}
+  {f f' : A $-> A'} (p : f $== f') {g g' : B $-> B'} (q : g $== g')
+  : functor_ab_tensor_prod f g $== functor_ab_tensor_prod f' g'.
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy.
+  intros a b; simpl.
+  exact (ap011 tensor (p _) (q _)).
+Defined.
+
+(** The tensor product functor preserves identity morphisms. *)
+Definition functor_ab_tensor_prod_id (A B : AbGroup)
+  : functor_ab_tensor_prod (Id A) (Id B) $== Id (ab_tensor_prod A B).
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy.
+  intros a b; simpl.
+  reflexivity.
+Defined.
+
+(** The tensor product functor preserves composition. *)
+Definition functor_ab_tensor_prod_compose {A B C A' B' C' : AbGroup}
+  (f : A $-> B) (g : B $-> C) (f' : A' $-> B') (g' : B' $-> C')
+  : functor_ab_tensor_prod (g $o f) (g' $o f')
+    $== functor_ab_tensor_prod g g' $o functor_ab_tensor_prod f f'.
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy.
+  intros a b; simpl.
+  reflexivity.
+Defined.
+
+(** The tensor product functor is a 0-bifunctor. *)
+Global Instance is0bifunctor_ab_tensor_prod : Is0Bifunctor ab_tensor_prod.
+Proof.
+  rapply Build_Is0Bifunctor'.
+  snrapply Build_Is0Functor.
+  intros [A B] [A' B'] [f g].
+  exact (functor_ab_tensor_prod f g).
+Defined.
+
+(** The tensor product functor is a bifunctor. *)
+Global Instance is1bifunctor_ab_tensor_prod : Is1Bifunctor ab_tensor_prod.
+Proof.
+  rapply Build_Is1Bifunctor'.
+  snrapply Build_Is1Functor.
+  - intros AB A'B' fg f'g' [p q].
+    exact (functor2_ab_tensor_prod p q).
+  - intros [A B].
+    exact (functor_ab_tensor_prod_id A B).
+  - intros AA' BB' CC' [f g] [f' g'].
+    exact (functor_ab_tensor_prod_compose f f' g g').
+Defined.
+
+(** ** Symmetry of the Tensor Product *)
+
+(** The tensor product is symmetric in that the order in which we take the tensor shouldn't matter upto isomorphism. *)
+
+(** We can define a swap map which swaps the order of simple tensors. *)
+Definition ab_tensor_swap {A B} : ab_tensor_prod A B $-> ab_tensor_prod B A.
+Proof.
+  snrapply ab_tensor_prod_rec. 
+  - exact (flip tensor).
+  - intros a b b'.
+    apply tensor_dist_r.
+  - intros a a' b.
+    apply tensor_dist_l.
+Defined.
+
+(** [ab_tensor_swap] is involutive. *)
+Definition ab_tensor_swap_swap {A B}
+  : ab_tensor_swap $o @ab_tensor_swap A B $== Id _. 
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy.
+  reflexivity.
+Defined. 
+
+(** [ab_tensor_swap] is natural in both arguments. This means that it also acts on tensor functors. *)
+Definition ab_tensor_swap_natural {A B A' B'} (f : A $-> A') (g : B $-> B')
+  : ab_tensor_swap $o functor_ab_tensor_prod f g
+    $== functor_ab_tensor_prod g f $o ab_tensor_swap.
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy.
+  simpl. (* This speeds up the [reflexivity] and the [Defined]. *)
+  reflexivity.
+Defined.
+
+(** The swap map gives us a symmetric braiding on the category of abelian groups. We will later show it is a full symmetric monoidal category. *)
+Global Instance symmetricbraiding_ab_tensor_prod : SymmetricBraiding ab_tensor_prod.
+Proof.
+  snrapply Build_SymmetricBraiding.
+  - snrapply Build_NatTrans.
+    + intro; exact ab_tensor_swap.
+    + snrapply Build_Is1Natural.
+      intros; nrapply ab_tensor_swap_natural.
+  - intros; nrapply ab_tensor_swap_swap.
+Defined. 
+
+(** ** Twisting Triple Tensors *)
+
+(** In order to construct the symmetric monoidal category, we will use what is termed the "Twist construction" in Monoidal.v. This simplifies the data of a symmetric monoidal category by constructing it from simpler parts. For instance, instead of having to prove full associativity [(A ⊗ B) ⊗ C $-> A ⊗ (B ⊗ C)], we can provide a twist map [A ⊗ (B ⊗ C) $-> B ⊗ (A ⊗ C)] and use the symmetric braiding we have so far to prove associativity. *)
+
+(** In order to be more efficient whilst unfolding definitions, we break up the definition of a twist map into its components. *)
+
+Local Definition ab_tensor_prod_twist_map {A B C : AbGroup}
+  : A -> (ab_tensor_prod B C $-> ab_tensor_prod B (ab_tensor_prod A C)).
+Proof.
+  intros a.
+  snrapply ab_tensor_prod_rec'.
+  - intros b.
+    exact (grp_homo_tensor_l b $o grp_homo_tensor_l a).
+  - intros b b' c; hnf.
+    nrapply tensor_dist_r.
+Defined.
+
+Local Definition ab_tensor_prod_twist_map_additive_l {A B C : AbGroup}
+  (a a' : A) (b : ab_tensor_prod B C)
+  : ab_tensor_prod_twist_map (a + a') b
+    = ab_tensor_prod_twist_map a b + ab_tensor_prod_twist_map a' b.
+Proof.  
+  revert b.
+  nrapply ab_tensor_prod_ind_homotopy_plus.
+  intros b c.
+  change (tensor b (tensor (a + a') c)
+    = tensor b (tensor a c) + tensor b (tensor a' c)). 
+  rhs_V nrapply tensor_dist_l.
+  nrapply (ap (tensor b)).
+  nrapply tensor_dist_r.
+Defined.
+
+(** Given a triple tensor product, we have a twist map which permutes the first two components. *)
+Definition ab_tensor_prod_twist {A B C}
+  : ab_tensor_prod A (ab_tensor_prod B C) $-> ab_tensor_prod B (ab_tensor_prod A C).
+Proof.
+  snrapply ab_tensor_prod_rec'.
+  - exact ab_tensor_prod_twist_map. 
+  - exact ab_tensor_prod_twist_map_additive_l.
+Defined.
+
+(** The twist map is involutive. *)
+Definition ab_tensor_prod_twist_twist {A B C}
+  : ab_tensor_prod_twist $o @ab_tensor_prod_twist A B C $== Id _.
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy_triple.
+  reflexivity.
+Defined.
+
+(** The twist map is natural in all 3 arguments. This means that the twist map acts on the triple tensor functor in the same way. *)
+Definition ab_tensor_prod_twist_natural {A B C A' B' C'}
+  (f : A $-> A') (g : B $-> B') (h : C $-> C')
+  : ab_tensor_prod_twist $o fmap11 ab_tensor_prod f (fmap11 ab_tensor_prod g h)
+    $== fmap11 ab_tensor_prod g (fmap11 ab_tensor_prod f h) $o ab_tensor_prod_twist.
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy_triple.
+  intros a b c.
+  (* This [change] speeds up the [reflexivity].  [simpl] produces a goal that looks the same, but is still slow. *)
+  change (tensor (g b) (tensor (f a) (h c)) = tensor (g b) (tensor (f a) (h c))).
+  reflexivity.
+Defined.
+
+(** ** Unitality of [abgroup_Z] *)
+
+(** In the symmetric monoidal structure on abelian groups, [abgroup_Z] is the unit. We show that tensoring with [abgroup_Z] on the right is isomorphic to the original group. *)
+
+(** First we characterise the action of integers via [grp_pow] and their interaction on tensors. This is just a generalisation of the distributivity laws for tensors. *)
+
+(** Multiplication in the first factor can be factored out. *)
+Definition tensor_ab_mul_l {A B : AbGroup} (z : Int) (a : A) (b : B)
+  : tensor (ab_mul z a) b = ab_mul z (tensor a b)
+  := ab_mul_natural (grp_homo_tensor_r b) z a.
+
+(** Multiplication in the second factor can be factored out. *)
+Definition tensor_ab_mul_r {A B : AbGroup} (z : Int) (a : A) (b : B)
+  : tensor a (ab_mul z b) = ab_mul z (tensor a b)
+  := ab_mul_natural (grp_homo_tensor_l a) z b.
+
+(** Multiplication can be transferred from one factor to the other. The tensor product of [R]-modules will include this as an extra axiom, but here we have [Z]-modules and we can prove it. *)
+Definition tensor_ab_mul {A B : AbGroup} (z : Int) (a : A) (b : B)
+  : tensor (ab_mul z a) b = tensor a (ab_mul z b).
+Proof.
+  rhs nrapply tensor_ab_mul_r.
+  nrapply tensor_ab_mul_l.
+Defined.
+
+(** [abgroup_Z] is a right identity for the tensor product. *) 
+Definition ab_tensor_prod_Z_r {A}
+  : ab_tensor_prod A abgroup_Z $<~> A.
+Proof.
+  (** Checking that the inverse map is a homomorphism is easier. *)
+  symmetry.
+  snrapply Build_GroupIsomorphism.
+  - nrapply grp_homo_tensor_r.
+    exact 1%int.
+  - snrapply isequiv_adjointify.
+    + snrapply ab_tensor_prod_rec'.
+      * exact grp_pow_homo.
+      * intros a a' z; cbn beta.
+        nrapply (grp_homo_op (ab_mul z)).
+    + hnf.
+      change (forall x : ?A, (grp_homo_map ?f) ((grp_homo_map ?g) x) = x)
+        with (f $o g $== Id _).
+      snrapply ab_tensor_prod_ind_homotopy.
+      intros a z.
+      change (tensor (B:=abgroup_Z) (grp_pow a z) 1%int = tensor a z).
+      lhs nrapply tensor_ab_mul.
+      nrapply ap.
+      lhs nrapply abgroup_Z_ab_mul.
+      apply int_mul_1_r.
+    + exact grp_unit_r.
+Defined.
+
+(** We have a right unitor for the tensor product given by unit [abgroup_Z]. Naturality of [ab_tensor_prod_Z_r] is straightforward to prove. *)
+Global Instance rightunitor_ab_tensor_prod
+  : RightUnitor ab_tensor_prod abgroup_Z.
+Proof.
+  snrapply Build_NatEquiv.
+  - intros A.
+    apply ab_tensor_prod_Z_r.
+  - snrapply Build_Is1Natural.
+    intros A A' f.
+    snrapply ab_tensor_prod_ind_homotopy.
+    intros a z.
+    change (grp_pow (f a) z = f (grp_pow a z)).
+    exact (grp_pow_natural _ _ _)^.
+Defined.
+
+(** Since we have symmetry of the tensor product, we get left unitality for free. *)
+Global Instance left_unitor_ab_tensor_prod
+  : LeftUnitor ab_tensor_prod abgroup_Z.
+Proof.
+  rapply left_unitor_twist.
+Defined.
+
+(** ** Symmetric Monoidal Structure of Tensor Product *)
+
+(** Using the twist construction we can derive an associator for the tensor product. In other words, we have associativity of the tensor product of abelian groups natural in each factor. *)
+Global Instance associator_ab_tensor_prod : Associator ab_tensor_prod.
+Proof.
+  srapply associator_twist.
+  - exact @ab_tensor_prod_twist.
+  - intros; nrapply ab_tensor_prod_twist_twist.
+  - intros; nrapply ab_tensor_prod_twist_natural.
+Defined.
+
+(** The triangle identity is straightforward to prove using the custom induction principles we proved earlier. *)
+Global Instance triangle_ab_tensor_prod
+  : TriangleIdentity ab_tensor_prod abgroup_Z.
+Proof.
+  snrapply triangle_twist.
+  intros A B.
+  snrapply ab_tensor_prod_ind_homotopy_triple.
+  intros a b z.
+  exact (tensor_ab_mul z a b)^.
+Defined.
+
+(** The hexagon identity is also straighforward to prove. We simply have to reduce all the involved functions on the simple tensors using our custom triple tensor induction principle. *)
+Global Instance hexagon_ab_tensor_prod : HexagonIdentity ab_tensor_prod.
+Proof.
+  snrapply hexagon_twist.
+  intros A B C.
+  snrapply ab_tensor_prod_ind_homotopy_triple.
+  intros b a c.
+  change (tensor c (tensor a b) = tensor c (tensor a b)).
+  reflexivity.
+Defined.
+
+(** Finally, we can prove the pentagon identity using the quadruple tensor induction principle. As we did before, the work only involves reducing the involved functions on the simple tensor redexes. *)
+Global Instance pentagon_ab_tensor_prod : PentagonIdentity ab_tensor_prod.
+Proof.
+  snrapply pentagon_twist.
+  intros A B C D.
+  snrapply ab_tensor_prod_ind_homotopy_quad.
+  intros a b c d.
+  change (tensor c (tensor d (tensor a b)) = tensor c (tensor d (tensor a b))). 
+  reflexivity.
+Defined.
+
+(** We therefore have all the data of a monoidal category. *)
+Global Instance ismonoidal_ab_tensor_prod
+  : IsMonoidal AbGroup ab_tensor_prod abgroup_Z
+  := {}.
+
+(** And furthermore, all the data of a symmetric monoidal category. *)
+Global Instance issymmmetricmonoidal_ab_tensor_prod
+  : IsSymmetricMonoidal AbGroup ab_tensor_prod abgroup_Z
+  := {}.
+
+(** ** Preservation of Coequalizers *)
+
+(** The tensor product of abelian groups preserves coequalizers, meaning that the coequalizer of two tensored groups is the tensor of the coequalizer. We show this is the case on the left and the right. *)
+
+(** Tensor products preserve coequalizers on the right. *)
+Definition grp_iso_ab_tensor_prod_coeq_l A {B C} (f g : B $-> C)
+  : ab_coeq (fmap01 ab_tensor_prod A f) (fmap01 ab_tensor_prod A g)
+    $<~> ab_tensor_prod A (ab_coeq f g).
+Proof.
+  snrapply cate_adjointify.
+  - snrapply ab_coeq_rec.
+    + rapply (fmap01 ab_tensor_prod A).
+      nrapply ab_coeq_in.
+    + refine (_^$ $@ fmap02 ab_tensor_prod _ _ $@ _).
+      1,3: rapply fmap01_comp.
+      nrapply ab_coeq_glue.
+  - snrapply ab_tensor_prod_rec'.
+    + intros a.
+      snrapply functor_ab_coeq.
+      1,2: snrapply (grp_homo_tensor_l a).
+      1,2: hnf; reflexivity.
+    + intros a a'; cbn beta.
+      srapply ab_coeq_ind_hprop.
+      intros x.
+      exact (ap (ab_coeq_in
+        (f:=fmap01 ab_tensor_prod A f)
+        (g:=fmap01 ab_tensor_prod A g))
+        (tensor_dist_r a a' x)).
+  - snrapply ab_tensor_prod_ind_homotopy.
+    intros a.
+    srapply ab_coeq_ind_hprop.
+    intros c.
+    reflexivity.
+  - snrapply ab_coeq_ind_homotopy.
+    snrapply ab_tensor_prod_ind_homotopy.
+    reflexivity.
+Defined.
+
+(** The equivalence respects the natural maps from [ab_tensor_prod A C]. *)
+Definition ab_tensor_prod_coeq_l_triangle A {B C} (f g : B $-> C)
+  : grp_iso_ab_tensor_prod_coeq_l A f g $o ab_coeq_in
+    $== fmap01 ab_tensor_prod A ab_coeq_in.
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy.
+  reflexivity.
+Defined.
+
+(** Tensor products preserve coequalizers on the left. *)
+Definition grp_iso_ab_tensor_prod_coeq_r {A B} (f g : A $-> B) C
+  : ab_coeq (fmap10 ab_tensor_prod f C) (fmap10 ab_tensor_prod g C)
+    $<~> ab_tensor_prod (ab_coeq f g) C.
+Proof.
+  refine (braide _ _ $oE _).
+  nrefine (grp_iso_ab_tensor_prod_coeq_l _ f g $oE _).
+  snrapply grp_iso_ab_coeq.
+  1,2: rapply braide.
+  1,2: symmetry; nrapply ab_tensor_swap_natural.
+Defined.
+
+(** The equivalence respects the natural maps from [ab_tensor_prod B C]. *)
+Definition ab_tensor_prod_coeq_r_triangle {A B} (f g : A $-> B) C
+  : grp_iso_ab_tensor_prod_coeq_r f g C $o ab_coeq_in
+    $== fmap10 ab_tensor_prod ab_coeq_in C.
+Proof.
+  snrapply ab_tensor_prod_ind_homotopy.
+  reflexivity.
+Defined.
+
+(** ** Tensor Product of Free Abelian Groups *)
+
+Definition equiv_ab_tensor_prod_freeabgroup X Y
+  : FreeAbGroup (X * Y) $<~> ab_tensor_prod (FreeAbGroup X) (FreeAbGroup Y).
+Proof.
+  srefine (let f:=_ in let g:=_ in cate_adjointify f g _ _).
+  - snrapply FreeAbGroup_rec.
+    intros [x y].
+    exact (tensor (freeabgroup_in x) (freeabgroup_in y)).
+  - snrapply ab_tensor_prod_rec.
+    + intros x.
+      snrapply FreeAbGroup_rec.
+      intros y; revert x.
+      unfold FreeAbGroup.
+      snrapply FreeAbGroup_rec.
+      intros x.
+      apply abel_unit.
+      apply freegroup_in.
+      exact (x, y).
+    + intros x y y'.
+      snrapply grp_homo_op.
+    + intros x x'.
+      rapply Abel_ind_hprop.
+      snrapply (FreeGroup_ind_homotopy _ (f' := ab_homo_add _ _)).
+      intros y.
+      lhs nrapply FreeGroup_rec_beta.
+      lhs nrapply grp_homo_op.
+      snrapply (ap011 (+) _^ _^).
+      1,2: nrapply FreeGroup_rec_beta.
+  - snrapply ab_tensor_prod_ind_homotopy.
+    intros x.
+    change (f $o g $o grp_homo_tensor_l x $== grp_homo_tensor_l x).
+    rapply Abel_ind_hprop.
+    change (@abel_in ?G) with (grp_homo_map (@abel_unit G)).
+    repeat change (cat_comp (A:=AbGroup) ?f ?g) with (cat_comp (A:=Group) f g).
+    change (forall y, grp_homo_map ?f (abel_unit y) = grp_homo_map ?g (abel_unit y))
+      with (cat_comp (A:=Group) f abel_unit $== cat_comp (A:=Group) g abel_unit).
+    rapply FreeGroup_ind_homotopy.
+    intros y; revert x.
+    change (f $o g $o grp_homo_tensor_r (freeabgroup_in y) $== grp_homo_tensor_r (freeabgroup_in y)).
+    rapply Abel_ind_hprop.
+    change (@abel_in ?G) with (grp_homo_map (@abel_unit G)).
+    repeat change (cat_comp (A:=AbGroup) ?f ?g) with (cat_comp (A:=Group) f g).
+    change (forall y, grp_homo_map ?f (abel_unit y) = grp_homo_map ?g (abel_unit y))
+      with (cat_comp (A:=Group) f abel_unit $== cat_comp (A:=Group) g abel_unit).
+    rapply FreeGroup_ind_homotopy.
+    intros x.
+    reflexivity.
+  - rapply Abel_ind_hprop.
+    change (GpdHom (A:=Hom(A:=Group) (FreeGroup (X * Y)) _)
+      (cat_comp (A:=Group) (g $o f) (@abel_unit (FreeGroup (X * Y))))
+      (@abel_unit (FreeGroup (X * Y)))).
+    snrapply FreeGroup_ind_homotopy.
+    reflexivity.
+Defined.
+
+(** ** Tensor products distribute over direct sums *)
+
+Definition ab_tensor_prod_dist_l {A B C : AbGroup}
+  : ab_tensor_prod A (ab_biprod B C)
+    $<~> ab_biprod (ab_tensor_prod A B) (ab_tensor_prod A C).
+Proof.
+  srapply (let f := _ in let g := _ in cate_adjointify f g _ _).
+  - snrapply ab_tensor_prod_rec.
+    + intros a bc.
+      exact (tensor a (fst bc), tensor a (snd bc)).
+    + intros a bc bc'; cbn beta.
+      snrapply path_prod'; snrapply tensor_dist_l.
+    + intros a a' bc; cbn beta.
+      snrapply path_prod; snrapply tensor_dist_r.
+  - snrapply ab_biprod_rec.
+    + exact (fmap01 ab_tensor_prod A ab_biprod_inl).
+    + exact (fmap01 ab_tensor_prod A ab_biprod_inr).
+  - snrapply ab_biprod_ind_homotopy.
+    + refine (cat_assoc _ _ _ $@ (_ $@L _) $@ _). 
+      1: snrapply ab_biprod_rec_beta_inl.
+      snrapply ab_tensor_prod_ind_homotopy.
+      intros a b.
+      snrapply path_prod; simpl.
+      * reflexivity.
+      * snrapply tensor_zero_r.
+    + refine (cat_assoc _ _ _ $@ (_ $@L _) $@ _).
+      1: snrapply ab_biprod_rec_beta_inr.
+      snrapply ab_tensor_prod_ind_homotopy.
+      intros a b.
+      snrapply path_prod; simpl.
+      * snrapply tensor_zero_r.
+      * reflexivity.
+  - snrapply ab_tensor_prod_ind_homotopy.
+    intros a [b c].
+    lhs_V nrapply tensor_dist_l; simpl.
+    snrapply ap.
+    symmetry; apply grp_prod_decompose.
+Defined.
+
+Definition ab_tensor_prod_dist_r {A B C : AbGroup}
+  : ab_tensor_prod (ab_biprod A B) C
+    $<~> ab_biprod (ab_tensor_prod A C) (ab_tensor_prod B C).
+Proof.
+  refine (emap11 ab_biprod (braide _ _) (braide _ _)
+    $oE _ $oE braide _ _).
+  snrapply ab_tensor_prod_dist_l.
+Defined.
+
+(** TODO: Show that the category of abelian groups is symmetric closed and therefore we have adjoint pair with the tensor and internal hom. This should allow us to prove lemmas such as tensors distributing over coproducts. *)
diff --git a/theories/Algebra/AbGroups/Z.v b/theories/Algebra/AbGroups/Z.v
index 2ac9c525870..2c9b32a525f 100644
--- a/theories/Algebra/AbGroups/Z.v
+++ b/theories/Algebra/AbGroups/Z.v
@@ -2,48 +2,51 @@ Require Import Basics.
 Require Import Spaces.Pos.Core Spaces.Int.
 Require Import Algebra.AbGroups.AbelianGroup.
 
+Local Set Universe Minimization ToSet.
+
 (** * The group of integers *)
 
 (** See also Cyclic.v for a definition of the integers as the free group on one generator. *)
 
 Local Open Scope int_scope.
 
-Section MinimizationToSet.
-
-Local Set Universe Minimization ToSet.
-
 Definition abgroup_Z@{} : AbGroup@{Set}.
 Proof.
-  snrapply Build_AbGroup.
-  - refine (Build_Group Int int_add 0 int_negation _); repeat split.
-    + exact _.
-    + exact int_add_assoc.
-    + exact int_add_0_r.
-    + exact int_add_negation_l.
-    + exact int_add_negation_r.
+  snrapply Build_AbGroup'.
+  - exact Int.
+  - exact 0.
+  - exact int_neg.
+  - exact int_add.
+  - exact _.
   - exact int_add_comm.
+  - exact int_add_assoc.
+  - exact int_add_0_l.
+  - exact int_add_neg_l.
 Defined.
 
-End MinimizationToSet.
-
-(** We can multiply by [n : Int] in any abelian group. *)
-Definition ab_mul (n : Int) {A : AbGroup} : GroupHomomorphism A A.
+(** For every group [G] and element [g : G], the map sending an integer to that power of [g] is a homomorphism.  See [ab_mul] for the homomorphism [G -> G] when [G] is abelian. *)
+Definition grp_pow_homo {G : Group} (g : G)
+  : GroupHomomorphism abgroup_Z G.
 Proof.
-  induction n.
-  - exact (grp_homo_compose ab_homo_negation (ab_mul_nat (pos_to_nat p))).
-  - exact grp_homo_const.
-  - exact (ab_mul_nat (pos_to_nat p)).
+  snrapply Build_GroupHomomorphism.
+  1: exact (grp_pow g).
+  intros m n; apply grp_pow_add.
 Defined.
 
-(** Homomorphisms respect multiplication. *)
-Lemma ab_mul_homo {A B : AbGroup} (n : Int) (f : GroupHomomorphism A B)
-  : grp_homo_compose f (ab_mul n) == grp_homo_compose (ab_mul n) f.
+Local Open Scope mc_add_scope.
+
+(** [ab_mul] (and [grp_pow]) give multiplication in [abgroup_Z]. *)
+Definition abgroup_Z_ab_mul (z z' : Int)
+  : ab_mul (A:=abgroup_Z) z z' = z * z'.
 Proof.
-  intro x.
-  induction n.
-  - cbn. refine (grp_homo_inv _ _ @ _).
-    refine (ap negate _).
-    apply grp_pow_homo.
-  - cbn. apply grp_homo_unit.
-  - cbn. apply grp_pow_homo.
+  induction z.
+  - reflexivity.
+  - cbn.
+    lhs nrapply (grp_pow_succ (G:=abgroup_Z)).
+    rhs nrapply int_mul_succ_l.
+    f_ap.
+  - cbn.
+    lhs nrapply (grp_pow_pred (G:=abgroup_Z)).
+    rhs nrapply int_mul_pred_l.
+    f_ap.
 Defined.
diff --git a/theories/Algebra/AbSES/BaerSum.v b/theories/Algebra/AbSES/BaerSum.v
index 6e77c489d91..e804c762aca 100644
--- a/theories/Algebra/AbSES/BaerSum.v
+++ b/theories/Algebra/AbSES/BaerSum.v
@@ -51,12 +51,19 @@ Proof.
   apply abses_pushout_pullback_reorder'.
 Defined.
 
-Global Instance isbifunctor_abses' `{Univalence}
-  : IsBifunctor (AbSES' : AbGroup^op -> AbGroup -> Type).
+Global Instance is0bifunctor_abses' `{Univalence}
+  : Is0Bifunctor (AbSES' : AbGroup^op -> AbGroup -> Type).
 Proof.
-  eapply Build_IsBifunctor.
+  rapply Build_Is0Bifunctor''.
+Defined.
+
+Global Instance is1bifunctor_abses' `{Univalence}
+  : Is1Bifunctor (AbSES' : AbGroup^op -> AbGroup -> Type).
+Proof.
+  snrapply Build_Is1Bifunctor''.
+  1,2: exact _.
   intros ? ? g ? ? f E; cbn.
-  apply abses_pushout_pullback_reorder.
+  exact (abses_pushout_pullback_reorder E f g).
 Defined.
 
 (** Given a short exact sequence [A -> E -> B] and maps [f : A -> A'], [g : B' -> B], we can change the order of pushing out along [f] and pulling back along [g]. *)
@@ -222,10 +229,17 @@ Proof.
   - intro; apply baer_sum_unit_r.
 Defined.
 
-Global Instance isbifunctor_abses `{Univalence}
-  : IsBifunctor (AbSES : AbGroup^op -> AbGroup -> pType).
+Global Instance is0bifunctor_abses `{Univalence}
+  : Is0Bifunctor (AbSES : AbGroup^op -> AbGroup -> pType).
+Proof.
+  rapply Build_Is0Bifunctor''.
+Defined.
+
+Global Instance is1bifunctor_abses `{Univalence}
+  : Is1Bifunctor (AbSES : AbGroup^op -> AbGroup -> pType).
 Proof.
-  econstructor.
+  snrapply Build_Is1Bifunctor''.
+  1,2: exact _.
   intros ? ? f ? ? g.
   rapply hspace_phomotopy_from_homotopy.
   1: apply ishspace_abses.
diff --git a/theories/Algebra/AbSES/Core.v b/theories/Algebra/AbSES/Core.v
index 8b0f9dda33a..6d76b4e707e 100644
--- a/theories/Algebra/AbSES/Core.v
+++ b/theories/Algebra/AbSES/Core.v
@@ -275,7 +275,7 @@ Global Instance is2graph_abses
 Global Instance is1cat_abses {A B : AbGroup@{u}}
   : Is1Cat (AbSES B A).
 Proof.
-  snrapply Build_Is1Cat.
+  snrapply Build_Is1Cat'.
   1: intros ? ?; apply is01cat_abses_path_data.
   1: intros ? ?; apply is0gpd_abses_path_data.
   3-5: cbn; reflexivity.
@@ -471,11 +471,11 @@ Proof.
     apply path_sigma_hprop; cbn.
     rapply equiv_path_grouphomomorphism; intros [a b]; cbn.
     apply path_prod; cbn.
-    + rewrite (ab_biprod_decompose a b).
+    + rewrite (grp_prod_decompose a b).
       refine (_ @ (grp_homo_op (ab_biprod_pr1 $o phi) _ _)^).
       apply grp_cancelR; symmetry.
       exact (ap fst (p a)).
-    + rewrite (ab_biprod_decompose a b).
+    + rewrite (grp_prod_decompose a b).
       refine (_ @ (grp_homo_op (ab_biprod_pr2 $o phi) _ _)^); cbn; symmetry.
       exact (ap011 _ (ap snd (p a)) (q (group_unit, b))^).
 Defined.
@@ -625,11 +625,17 @@ Proposition projection_split_beta {B A : AbGroup} (E : AbSES B A)
   : projection_split_iso E h o (inclusion _) == ab_biprod_inl.
 Proof.
   intro a.
-  refine (ap _ (ab_corec_beta _ _ _ _) @ _).
-  refine (ab_biprod_functor_beta _ _ _ _ _ @ _).
+  (* The next two lines might help the reader, but both are definitional equalities:
+  lhs nrapply (ap _ (grp_prod_corec_natural _ _ _ _)).
+  lhs nrapply ab_biprod_functor_beta.
+  *)
   nrapply path_prod'.
   2: rapply cx_isexact.
-  refine (ap _ (projection_split_to_kernel_beta E h a) @ _).
+  (* The LHS of the remaining goal is definitionally equal to
+       (grp_iso_inverse (grp_iso_cxfib (isexact_inclusion_projection E)) $o
+         (projection_split_to_kernel E h $o inclusion E)) a
+     allowing us to do: *)
+  lhs nrapply (ap _ (projection_split_to_kernel_beta E h a)).
   apply eissect.
 Defined.
 
@@ -731,8 +737,7 @@ Proof.
   - apply isequiv_surj_emb.
     1: rapply cancelR_conn_map.
     apply isembedding_isinj_hset.
-    srapply Quotient_ind_hprop; intro x.
-    srapply Quotient_ind_hprop; intro y.
+    srapply Quotient_ind2_hprop; intros x y.
     intro p.
     apply qglue; cbn.
     refine (isexact_preimage (Tr (-1)) _ _ (-x + y) _).
diff --git a/theories/Algebra/AbSES/Ext.v b/theories/Algebra/AbSES/Ext.v
index 5f937264e2a..317a9f4cd35 100644
--- a/theories/Algebra/AbSES/Ext.v
+++ b/theories/Algebra/AbSES/Ext.v
@@ -2,7 +2,7 @@ Require Import Basics Types Truncations.Core.
 Require Import Pointed WildCat.
 Require Import Truncations.SeparatedTrunc.
 Require Import AbelianGroup AbHom AbProjective.
-Require Import AbSES.Pullback AbSES.BaerSum AbSES.Core.
+Require Import AbSES.Pullback AbSES.Pushout AbSES.BaerSum AbSES.Core.
 
 Local Open Scope mc_scope.
 Local Open Scope mc_add_scope.
@@ -11,6 +11,14 @@ Local Open Scope mc_add_scope.
 
 Definition Ext (B A : AbGroup@{u}) := pTr 0 (AbSES B A).
 
+Global Instance is0bifunctor_ext `{Univalence}
+  : Is0Bifunctor (Ext : AbGroup^op -> AbGroup -> pType)
+  := is0bifunctor_postcompose _ _ (bf:=is0bifunctor_abses).
+
+Global Instance is1bifunctor_ext `{Univalence}
+  : Is1Bifunctor (Ext : AbGroup^op -> AbGroup -> pType)
+  := is1bifunctor_postcompose _ _ (bf:=is1bifunctor_abses).
+
 (** An extension [E : AbSES B A] is trivial in [Ext B A] if and only if [E] merely splits. *)
 Proposition iff_ab_ext_trivial_split `{Univalence} {B A : AbGroup} (E : AbSES B A)
   : merely {s : GroupHomomorphism B E & (projection _) $o s == idmap}
@@ -24,9 +32,13 @@ Defined.
 
 Definition Ext' (B A : AbGroup@{u}) := Tr 0 (AbSES' B A).
 
-Global Instance isbifunctor_ext'@{u v w | u < v, v < w} `{Univalence}
-  : IsBifunctor@{v v w u u v v} (Ext' : AbGroup@{u}^op -> AbGroup@{u} -> Type@{v})
-  := isbifunctor_compose _ _ (P:=isbifunctor_abses').
+Global Instance is0bifunctor_ext' `{Univalence}
+  : Is0Bifunctor (Ext' : AbGroup^op -> AbGroup -> Type)
+  := is0bifunctor_postcompose _ _ (bf:=is0bifunctor_abses').
+
+Global Instance is1bifunctor_ext' `{Univalence}
+  : Is1Bifunctor (Ext' : AbGroup^op -> AbGroup -> Type)
+  := is1bifunctor_postcompose _ _ (bf:=is1bifunctor_abses').
 
 (** [Ext B A] is an abelian group for any [A B : AbGroup]. The proof of commutativity is a bit faster if we separate out the proof that [Ext B A] is a group. *)
 Definition grp_ext `{Univalence} (B A : AbGroup@{u}) : Group.
@@ -51,48 +63,74 @@ Defined.
 
 (** ** The bifunctor [ab_ext] *)
 
-Definition ab_ext `{Univalence} (B A : AbGroup@{u}) : AbGroup.
+Definition ab_ext@{u v|u < v} `{Univalence} (B : AbGroup@{u}^op) (A : AbGroup@{u}) : AbGroup@{v}.
 Proof.
-  snrapply (Build_AbGroup (grp_ext B A)).
+  snrapply (Build_AbGroup (grp_ext@{u v} B A)).
   intros E F.
   strip_truncations; cbn.
   apply ap.
   apply baer_sum_commutative.
 Defined.
 
-Global Instance is01functor_ext `{Univalence} (B : AbGroup^op)
+Global Instance is0functor_abext01 `{Univalence} (B : AbGroup^op)
   : Is0Functor (ab_ext B).
 Proof.
   srapply Build_Is0Functor; intros ? ? f.
   snrapply Build_GroupHomomorphism.
-  1: exact (fmap01 (A:=AbGroup^op) Ext' B f).
+  1: exact (fmap (Ext B) f).
   rapply Trunc_ind; intro E0.
   rapply Trunc_ind; intro E1.
   apply (ap tr); cbn.
   apply baer_sum_pushout.
 Defined.
 
-Global Instance is10functor_ext `{Univalence} (A : AbGroup)
+Global Instance is0functor_abext10 `{Univalence} (A : AbGroup)
   : Is0Functor (fun B : AbGroup^op => ab_ext B A).
 Proof.
   srapply Build_Is0Functor; intros ? ? f; cbn.
   snrapply Build_GroupHomomorphism.
-  1: exact (fmap10 (A:=AbGroup^op) Ext' f A).
+  1: exact (fmap (fun (B : AbGroup^op) => Ext B A) f).
   rapply Trunc_ind; intro E0.
   rapply Trunc_ind; intro E1.
   apply (ap tr); cbn.
   apply baer_sum_pullback.
 Defined.
 
-Global Instance isbifunctor_ext `{Univalence}
-  : IsBifunctor (A:=AbGroup^op) ab_ext.
+Global Instance is1functor_abext01 `{Univalence} (B : AbGroup^op)
+  : Is1Functor (ab_ext B).
+Proof.
+  snrapply Build_Is1Functor.
+  - intros A C f g.
+    exact (fmap2 (Ext B)).
+  - exact (fmap_id (Ext B)).
+  - intros A C D.
+    exact (fmap_comp (Ext B)).
+Defined.
+
+Global Instance is1functor_abext10 `{Univalence} (A : AbGroup)
+  : Is1Functor (fun B : AbGroup^op => ab_ext B A).
+Proof.
+  snrapply Build_Is1Functor.
+  - intros B C f g.
+    exact (fmap2 (fun B : AbGroup^op => Ext B A)).
+  - exact (fmap_id (fun B : AbGroup^op => Ext B A)).
+  - intros B C D.
+    exact (fmap_comp (fun B : AbGroup^op => Ext B A)).
+Defined.
+
+Global Instance is0bifunctor_abext `{Univalence}
+  : Is0Bifunctor (A:=AbGroup^op) ab_ext.
+Proof.
+  rapply Build_Is0Bifunctor''.
+Defined.
+
+Global Instance is1bifunctor_abext `{Univalence}
+  : Is1Bifunctor (A:=AbGroup^op) ab_ext.
 Proof.
-  snrapply Build_IsBifunctor.
+  snrapply Build_Is1Bifunctor''.
   1,2: exact _.
-  intros B B' f A A' g.
-  rapply Trunc_ind; intro E.
-  apply (ap tr).
-  apply abses_pushout_pullback_reorder.
+  intros A B.
+  exact (bifunctor_coh (Ext : AbGroup^op -> AbGroup -> pType)).
 Defined.
 
 (** We can push out a fixed extension while letting the map vary, and this defines a group homomorphism. *)
diff --git a/theories/Algebra/AbSES/PullbackFiberSequence.v b/theories/Algebra/AbSES/PullbackFiberSequence.v
index b7cd4c2e97b..a8a4dce0af9 100644
--- a/theories/Algebra/AbSES/PullbackFiberSequence.v
+++ b/theories/Algebra/AbSES/PullbackFiberSequence.v
@@ -266,7 +266,7 @@ Proof.
   refine (cat_assoc _ _ _ $@ _).
   apply gpd_moveR_Vh.
   apply gpd_moveL_hM.
-  apply equiv_path_biprod_corec.
+  apply equiv_ab_biprod_ind_homotopy.
   split; apply equiv_path_pullback_rec_hset; split; cbn.
   - intro a.
     exact (ap (class_of _ o pullback_pr1) (fst p^$.2 a)).
diff --git a/theories/Algebra/AbSES/Pushout.v b/theories/Algebra/AbSES/Pushout.v
index 022f02b7979..ea70463902b 100644
--- a/theories/Algebra/AbSES/Pushout.v
+++ b/theories/Algebra/AbSES/Pushout.v
@@ -85,7 +85,7 @@ Proof.
     1: apply issurj_class_of.
     2: exact _.
     intro x; simpl.
-    refine (grp_homo_op (projection F) _ _ @ ap011 (+) _ _ @ (grp_homo_op _ _ _ )^).
+    nrapply grp_homo_op_agree.
     + refine (_ @ (grp_homo_unit _)^).
       apply iscomplex_abses.
     + apply right_square.
diff --git a/theories/Algebra/AbSES/SixTerm.v b/theories/Algebra/AbSES/SixTerm.v
index 34a8ccb7e9d..46b8e1d96fb 100644
--- a/theories/Algebra/AbSES/SixTerm.v
+++ b/theories/Algebra/AbSES/SixTerm.v
@@ -1,6 +1,6 @@
 Require Import Basics Types WildCat HSet Pointed.Core Pointed.pTrunc Pointed.pEquiv
   Modalities.ReflectiveSubuniverse Truncations.Core Truncations.SeparatedTrunc
-  AbGroups Homotopy.ExactSequence
+  AbGroups Homotopy.ExactSequence Spaces.Int Spaces.FreeInt
   AbSES.Core AbSES.Pullback AbSES.Pushout BaerSum Ext PullbackFiberSequence.
 
 (** * The contravariant six-term sequence of Ext *)
@@ -194,7 +194,7 @@ Local Definition isexact_ext_cyclic_ab_iii@{u v w | u < v, v < w} `{Univalence}
 Local Definition ext_cyclic_exact@{u v w} `{Univalence}
   (n : nat) `{IsEmbedding (Z1_mul_nat n)} {A : AbGroup@{u}}
   : IsExact@{v v v v v} (Tr (-1))
-      (ab_mul_nat (A:=A) n)
+      (ab_mul (A:=A) n)
       (abses_pushout_ext@{u w v} (abses_from_inclusion (Z1_mul_nat n))
          o* (pequiv_groupisomorphism (equiv_Z1_hom A))^-1*).
 Proof.
@@ -211,7 +211,7 @@ Proof.
     apply moveR_equiv_V; symmetry.
     refine (ap f _ @ _).
     1: apply Z1_rec_beta.
-    exact (ab_mul_nat_homo f n Z1_gen).
+    exact (ab_mul_natural f n Z1_gen).
   - (* we get rid of [equiv_Z1_hom] *)
     apply isexact_equiv_fiber.
     apply isexact_ext_cyclic_ab_iii.
@@ -220,12 +220,12 @@ Defined.
 (** The main result of this section. *)
 Theorem ext_cyclic_ab@{u v w | u < v, v < w} `{Univalence}
   (n : nat) `{emb : IsEmbedding (Z1_mul_nat n)} {A : AbGroup@{u}}
-  : ab_cokernel@{v w} (ab_mul_nat (A:=A) n)
+  : ab_cokernel@{v w} (ab_mul (A:=A) n)
       $<~> ab_ext@{u v} (cyclic'@{u v} n) A.
   (* We take a large cokernel in order to apply [abses_cokernel_iso]. *)
 Proof.
   pose (E := abses_from_inclusion (Z1_mul_nat n)).
-  snrefine (abses_cokernel_iso (ab_mul_nat n) _).
+  snrefine (abses_cokernel_iso (ab_mul n) _).
   - exact (grp_homo_compose
              (abses_pushout_ext E)
              (grp_iso_inverse (equiv_Z1_hom A))).
diff --git a/theories/Algebra/Categorical/MonoidObject.v b/theories/Algebra/Categorical/MonoidObject.v
new file mode 100644
index 00000000000..65dcbb15283
--- /dev/null
+++ b/theories/Algebra/Categorical/MonoidObject.v
@@ -0,0 +1,276 @@
+Require Import Basics.Overture Basics.Tactics.
+Require Import WildCat.Core WildCat.Equiv WildCat.Monoidal WildCat.Bifunctor
+  WildCat.NatTrans WildCat.Opposite WildCat.Products.
+Require Import abstract_algebra.
+
+(** * Monoids and Comonoids *)
+
+(** Here we define a monoid internal to a monoidal category. Note that we don't actually need the full monoidal structure so we assume only the parts we need. This allows us to keep the definitions general between various flavours of monoidal category.
+
+Many algebraic theories such as groups and rings may also be internalized, however these specifically require a cartesian monoidal structure. The theory of monoids however has no such requirement and can therefore be developed in much greater generality. This can be used to define a range of objects such as R-algebras, H-spaces, Hopf algebras and more. *)
+
+(** * Monoid objects *)
+
+Section MonoidObject.
+  Context {A : Type} {tensor : A -> A -> A} {unit : A}
+    `{HasEquivs A, !Is0Bifunctor tensor, !Is1Bifunctor tensor}
+    `{!Associator tensor, !LeftUnitor tensor unit, !RightUnitor tensor unit}.
+
+  (** An object [x] of [A] is a monoid object if it comes with the following data: *)
+  Class IsMonoidObject (x : A) := {
+    (** A multiplication map from the tensor product of [x] with itself to [x]. *)
+    mo_mult : tensor x x $-> x;
+    (** A unit of the multplication. *)
+    mo_unit : unit $-> x;
+    (** The multiplication map is associative. *)
+    mo_assoc : mo_mult $o fmap10 tensor mo_mult x $o associator x x x
+        $== mo_mult $o fmap01 tensor x mo_mult;
+    (** The multiplication map is left unital. *)
+    mo_left_unit : mo_mult $o fmap10 tensor mo_unit x $== left_unitor x;
+    (** The multiplication map is right unital. *)
+    mo_right_unit : mo_mult $o fmap01 tensor x mo_unit $== right_unitor x;
+  }.
+
+  Context `{!Braiding tensor}.
+
+  (** An object [x] of [A] is a commutative monoid object if: *)
+  Class IsCommutativeMonoidObject (x : A) := {
+    (** It is a monoid object. *)
+    cmo_mo :: IsMonoidObject x;
+    (** The multiplication map is commutative. *)
+    cmo_comm : mo_mult $o braid x x $== mo_mult;
+  }.
+
+End MonoidObject.
+
+Arguments IsMonoidObject {A} tensor unit {_ _ _ _ _ _ _ _ _ _} x.
+Arguments IsCommutativeMonoidObject {A} tensor unit {_ _ _ _ _ _ _ _ _ _ _} x.
+
+Section ComonoidObject.
+  Context {A : Type} (tensor : A -> A -> A) (unit : A)
+    `{HasEquivs A, !Is0Bifunctor tensor, !Is1Bifunctor tensor}
+    `{!Associator tensor, !LeftUnitor tensor unit, !RightUnitor tensor unit}.
+
+  (** A comonoid object is a monoid object in the opposite category. *)
+  Class IsComonoidObject (x : A)
+    := ismonoid_comonoid_op :: IsMonoidObject (A:=A^op) tensor unit x.
+
+  (** We can build comonoid objects from the following data: *)
+  Definition Build_IsComonoidObject (x : A)
+    (** A comultplication map. *)
+    (co_comult : x $-> tensor x x)
+    (** A counit. *)
+    (co_counit : x $-> unit)
+    (** The comultiplication is coassociative. *)
+    (co_coassoc : associator x x x $o fmap01 tensor x co_comult $o co_comult
+        $== fmap10 tensor co_comult x $o co_comult)
+    (** The comultiplication is left counital. *)
+    (co_left_counit : left_unitor x $o fmap10 tensor co_counit x $o co_comult $== Id x)
+    (** The comultiplication is right counital. *)
+    (co_right_counit : right_unitor x $o fmap01 tensor x co_counit $o co_comult $== Id x)
+    : IsComonoidObject x.
+  Proof.
+    snrapply Build_IsMonoidObject.
+    - exact co_comult.
+    - exact co_counit.
+    - nrapply cate_moveR_eV.
+      symmetry.
+      nrefine (cat_assoc _ _ _ $@ _).
+      rapply co_coassoc.
+    - simpl; nrefine (_ $@ cat_idr _).
+      nrapply cate_moveL_Ve.
+      nrefine (cat_assoc_opp _ _ _ $@ _).
+      exact co_left_counit.
+    - simpl; nrefine (_ $@ cat_idr _).
+      nrapply cate_moveL_Ve.
+      nrefine (cat_assoc_opp _ _ _ $@ _).
+      exact co_right_counit.
+  Defined.
+
+  (** Comultiplication *)
+  Definition co_comult {x : A} `{!IsComonoidObject x} : x $-> tensor x x
+   := mo_mult (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x).
+
+  (** Counit *)
+  Definition co_counit {x : A} `{!IsComonoidObject x} : x $-> unit
+    := mo_unit (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x).
+
+  (** Coassociativity *)
+  Definition co_coassoc {x : A} `{!IsComonoidObject x}
+    : associator x x x $o fmap01 tensor x co_comult $o co_comult
+        $== fmap10 tensor co_comult x $o co_comult.
+  Proof.
+    refine (cat_assoc _ _ _ $@ _).
+    apply cate_moveR_Me.
+    symmetry.
+    exact (mo_assoc (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x)).
+  Defined.
+
+  (** Left counitality *)
+  Definition co_left_counit {x : A} `{!IsComonoidObject x}
+    : left_unitor x $o fmap10 tensor co_counit x $o co_comult $== Id x.
+  Proof.
+    refine (cat_assoc _ _ _ $@ _).
+    apply cate_moveR_Me.
+    refine (_ $@ (cat_idr _)^$).
+    exact (mo_left_unit (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x)).
+  Defined.
+
+  (** Right counitality *)
+  Definition co_right_counit {x : A} `{!IsComonoidObject x}
+    : right_unitor x $o fmap01 tensor x co_counit $o co_comult $== Id x.
+  Proof.
+    refine (cat_assoc _ _ _ $@ _).
+    apply cate_moveR_Me.
+    refine (_ $@ (cat_idr _)^$).
+    exact (mo_right_unit (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x)).
+  Defined.
+
+  Context `{!Braiding tensor}.
+
+  (** A cocommutative comonoid objects is a commutative monoid object in the opposite category. *)
+  Class IsCocommutativeComonoidObject (x : A)
+    := iscommuatativemonoid_cocomutativemonoid_op
+      :: IsCommutativeMonoidObject (A:=A^op) tensor unit x.
+
+  (** We can build cocommutative comonoid objects from the following data: *)
+  Definition Build_IsCocommutativeComonoidObject (x : A)
+    (** A comonoid. *)
+    `{!IsComonoidObject x}
+    (** Together with a proof of cocommutativity. *)
+    (cco_cocomm : braid x x $o co_comult $== co_comult)
+    : IsCocommutativeComonoidObject x.
+  Proof.
+    snrapply Build_IsCommutativeMonoidObject.
+    - exact _.
+    - exact cco_cocomm.
+  Defined.
+
+  Global Instance co_cco {x : A} `{!IsCocommutativeComonoidObject x}
+    : IsComonoidObject x.
+  Proof.
+    apply cmo_mo.
+  Defined.
+
+  (** Cocommutativity *)
+  Definition cco_cocomm {x : A} `{!IsCocommutativeComonoidObject x}
+    : braid x x $o co_comult $== co_comult.
+  Proof.
+    exact (cmo_comm (A:=A^op) (tensor:=tensor) (unit:=unit) (x:=x)).
+  Defined.
+
+End ComonoidObject.
+
+(** A comonoid object in [A^op] is a monoid object in [A]. *)
+Definition mo_co_op {A : Type} {tensor : A -> A -> A} {unit : A}
+  `{HasEquivs A, !Is0Bifunctor tensor, !Is1Bifunctor tensor}
+  `{!Associator tensor, !LeftUnitor tensor unit, !RightUnitor tensor unit}
+  {x : A} `{C : !IsComonoidObject (A:=A^op) tensor unit x}
+  : IsMonoidObject tensor unit x.
+Proof.
+  snrapply Build_IsMonoidObject.
+  - exact (co_comult (A:=A^op) tensor unit).
+  - exact (co_counit (A:=A^op) tensor unit).
+  - apply cate_moveR_eM.
+    symmetry.
+    exact (cat_assoc _ _ _ $@ co_coassoc (A:=A^op) tensor unit (x:=x)).
+  - simpl; nrefine (_ $@ cat_idl _).
+    apply cate_moveL_eM.
+    refine (cat_assoc _ _ _ $@ _).
+    exact (co_left_counit (A:=A^op) tensor unit (x:=x)).
+  - simpl; nrefine (_ $@ cat_idl _).
+    apply cate_moveL_eM.
+    refine (cat_assoc _ _ _ $@ _).
+    exact (co_right_counit (A:=A^op) tensor unit (x:=x)).
+Defined.
+
+(** A cocommutative cocomonoid object in [A^op] is a commutative monoid object in [A]. *)
+Definition cmo_coco_op {A : Type} {tensor : A -> A -> A} {unit : A}
+  `{HasEquivs A, !Is0Bifunctor tensor, !Is1Bifunctor tensor}
+  `{!Associator tensor, !LeftUnitor tensor unit, !RightUnitor tensor unit,
+    !Braiding tensor}
+  {x : A} `{C : !IsCocommutativeComonoidObject (A:=A^op) tensor unit x}
+  : IsCommutativeMonoidObject tensor unit x.
+Proof.
+  snrapply Build_IsCommutativeMonoidObject.
+  - nrapply mo_co_op.
+    rapply co_cco.
+  - exact (cco_cocomm (A:=A^op) tensor unit).
+Defined.
+
+(** ** Monoid enrichment *)
+
+(** A hom [x $-> y] in a cartesian category where [y] is a monoid object has the structure of a monoid. Equivalently, a hom [x $-> y] in a cartesian category where [x] is a comonoid object has the structure of a monoid. *)
+
+Section MonoidEnriched.
+  Context {A : Type} `{HasEquivs A} `{!HasBinaryProducts A}
+    (unit : A) `{!IsTerminal unit} {x y : A}
+    `{!HasMorExt A} `{forall x y, IsHSet (x $-> y)}.
+
+  Section Monoid.
+    Context `{!IsMonoidObject _ _ y}.
+
+    Local Instance sgop_hom : SgOp (x $-> y)
+      := fun f g => mo_mult $o cat_binprod_corec f g.
+
+    Local Instance monunit_hom : MonUnit (x $-> y) := mo_unit $o mor_terminal _ _.
+
+    Local Instance associative_hom : Associative sgop_hom.
+    Proof.
+      intros f g h.
+      unfold sgop_hom.
+      rapply path_hom.
+      refine ((_ $@L cat_binprod_fmap01_corec _ _ _)^$ $@ _).
+      nrefine (cat_assoc_opp _ _ _ $@ _).
+      refine ((mo_assoc $@R _)^$ $@ _).
+      nrefine (_ $@ (_ $@L cat_binprod_fmap10_corec _ _ _)).
+      refine (cat_assoc _ _ _ $@ (_ $@L _) $@ cat_assoc _ _ _).
+      nrapply cat_binprod_associator_corec.
+    Defined.
+
+    Local Instance leftidentity_hom : LeftIdentity sgop_hom mon_unit.
+    Proof.
+      intros f.
+      unfold sgop_hom, mon_unit.
+      rapply path_hom.
+      refine ((_ $@L (cat_binprod_fmap10_corec _ _ _)^$) $@ cat_assoc_opp _ _ _ $@ _).
+      nrefine (((mo_left_unit $@ _) $@R _) $@ _).
+      1: nrapply cate_buildequiv_fun.
+      unfold trans_nattrans.
+      nrefine ((((_ $@R _) $@ _) $@R _) $@ _).
+      1: nrapply cate_buildequiv_fun.
+      1: nrapply cat_binprod_beta_pr1.
+      nrapply cat_binprod_beta_pr2.
+    Defined.
+
+    Local Instance rightidentity_hom : RightIdentity sgop_hom mon_unit.
+    Proof.
+      intros f.
+      unfold sgop_hom, mon_unit.
+      rapply path_hom.
+      refine ((_ $@L (cat_binprod_fmap01_corec _ _ _)^$) $@ cat_assoc_opp _ _ _ $@ _).
+      nrefine (((mo_right_unit $@ _) $@R _) $@ _).
+      1: nrapply cate_buildequiv_fun.
+      nrapply cat_binprod_beta_pr1.
+    Defined.
+
+    Local Instance issemigroup_hom : IsSemiGroup (x $-> y) := {}.
+    Local Instance ismonoid_hom : IsMonoid (x $-> y) := {}.
+
+  End Monoid.
+
+  Context `{!IsCommutativeMonoidObject _ _ y}.
+  Local Existing Instances sgop_hom monunit_hom ismonoid_hom.
+
+  Local Instance commutative_hom : Commutative sgop_hom.
+  Proof.
+    intros f g.
+    unfold sgop_hom.
+    rapply path_hom.
+    refine ((_ $@L _^$) $@ cat_assoc_opp _ _ _ $@ (cmo_comm $@R _)).
+    nrapply cat_binprod_swap_corec. 
+  Defined.
+
+  Local Instance iscommutativemonoid_hom : IsCommutativeMonoid (x $-> y) := {}.
+
+End MonoidEnriched.
diff --git a/theories/Algebra/Congruence.v b/theories/Algebra/Congruence.v
index f344ecb9109..5c8ba28c89b 100644
--- a/theories/Algebra/Congruence.v
+++ b/theories/Algebra/Congruence.v
@@ -1,4 +1,4 @@
-Require Import Classes.interfaces.abstract_algebra.
+Require Import Classes.interfaces.canonical_names.
 
 (* We say that a relation is a congruence if it respects the operation.
   This is technically incorrect since we are not enforcing the relation to be an equivalence relation.
diff --git a/theories/Algebra/Groups/FreeGroup.v b/theories/Algebra/Groups/FreeGroup.v
index f17f518e525..15a273651f5 100644
--- a/theories/Algebra/Groups/FreeGroup.v
+++ b/theories/Algebra/Groups/FreeGroup.v
@@ -1,7 +1,7 @@
 Require Import Basics Types Group Subgroup
-  WildCat.Core Colimits.Coeq
+  WildCat.Core WildCat.Universe Colimits.Coeq
   Truncations.Core Truncations.SeparatedTrunc
-  Classes.implementations.list.
+  Spaces.List.Core Spaces.List.Theory.
 
 Local Open Scope mc_scope.
 Local Open Scope mc_mult_scope.
@@ -14,6 +14,8 @@ Section Reduction.
 
   Universe u.
   Context (A : Type@{u}).
+  
+  Local Open Scope list_scope.
 
   (** We define words (with inverses) on A to be lists of marked elements of A *)
   Local Definition Words : Type@{u} := list (A + A).
@@ -22,7 +24,7 @@ Section Reduction.
   Local Definition change_sign : A + A -> A + A := equiv_sum_symm A A.
 
   (** We introduce a local notation for [change_sign]. It is only defined in this section however. *)
-  Local Notation "x ^" := (change_sign x).
+  Local Notation "a ^" := (change_sign a).
 
   (** Changing sign is an involution *)
   Local Definition change_sign_inv a : a^^ = a.
@@ -30,48 +32,30 @@ Section Reduction.
     by destruct a.
   Defined.
 
-  (** We can concatenate words using list concatenation *)
-  Local Definition word_concat : Words -> Words -> Words := @app _.
-
-  (** We introduce a local notation for word_concat. *)
-  Local Infix "@" := word_concat.
-
-  Local Definition word_concat_w_nil x : x @ nil = x.
-  Proof.
-    induction x; trivial.
-    cbn; f_ap.
-  Defined.
-
-  Local Definition word_concat_w_ww x y z : x @ (y @ z) = (x @ y) @ z.
-  Proof.
-    apply app_assoc.
-  Defined.
-
-  (** Singleton word *)
-  Local Definition word_sing (x : A + A) : Words := (cons x nil).
-
-  Local Notation "[ x ]" := (word_sing x).
-
   (** Now we wish to define the free group on A as the following HIT: 
 
     HIT N(A) : hSet
      | eta : Words -> N(A)
      | tau (x : Words) (a : A + A) (y : Words)
-         : eta (x @ [a] @ [a^] @ y) = eta (x @ y).
+         : eta (x ++ [a] ++ [a^] ++ y) = eta (x ++ y).
 
     Since we cannot write our HITs directly like this (without resorting to private inductive types), we will construct this HIT out of HITs we know. In fact, we can define N(A) as a coequalizer. *)
 
   Local Definition map1 : Words * (A + A) * Words -> Words.
   Proof.
     intros [[x a] y].
-    exact (x @ [a] @ [a^] @ y).
+    exact (x ++ [a] ++ [a^] ++ y).
   Defined.
+  
+  Arguments map1 _ /.
 
   Local Definition map2 : Words * (A + A) * Words -> Words.
   Proof.
     intros [[x a] y].
-    exact (x @ y).
+    exact (x ++ y).
   Defined.
+  
+  Arguments map2 _ /.
 
   (** Now we can define the underlying type of the free group as the 0-truncated coequalizer of these two maps *)
   Definition freegroup_type : Type := Tr 0 (Coeq map1 map2).
@@ -81,7 +65,7 @@ Section Reduction.
 
   (** This is the path constructor *)
   Definition freegroup_tau (x : Words) (a : A + A) (y : Words)
-    : freegroup_eta (x @ [a] @ [a^] @ y) = freegroup_eta (x @ y).
+    : freegroup_eta (x ++ [a] ++ [a^] ++ y) = freegroup_eta (x ++ y).
   Proof.
     apply path_Tr, tr.
     exact ((cglue (x, a, y))).
@@ -96,87 +80,86 @@ Section Reduction.
     { intros x; revert y.
       snrapply Coeq_rec.
       { intros y.
-        exact (freegroup_eta (x @ y)). }
-      intros [[y a] z]; cbn.
-      refine (concat (ap _ _) _).
-      { refine (concat (word_concat_w_ww _ _ _) _).
-        rapply (ap (fun t => t @ _)).
-        refine (concat (word_concat_w_ww _ _ _) _).
-        rapply (ap (fun t => t @ _)).
-        refine (word_concat_w_ww _ _ _). }
-      refine (concat _ (ap _ _^)).
-      2: apply word_concat_w_ww.
-      apply freegroup_tau. }
+        exact (freegroup_eta (x ++ y)). }
+      intros [[y a] z]; simpl.
+      change (freegroup_eta (x ++ y ++ ([a] ++ [a^] ++ z))
+        = freegroup_eta (x ++ y ++ z)).
+      rhs nrapply ap.
+      2: nrapply app_assoc.
+      lhs nrapply ap.
+      1: nrapply app_assoc.
+      nrapply (freegroup_tau _ a). }
     intros [[c b] d].
-    simpl.
     revert y.
-    snrapply Coeq_ind.
-    { simpl.
-      intro a.
-      rewrite <- word_concat_w_ww.
-      rewrite <- (word_concat_w_ww _ _ a).
-      rapply (freegroup_tau c b (d @ a)). }
-    intro; rapply path_ishprop.
+    srapply Coeq_ind_hprop.
+    intro a.
+    change (freegroup_eta ((c ++ [b] ++ [b^] ++ d) ++ a)
+      = freegroup_eta ((c ++ d) ++ a)).
+    lhs_V nrapply ap.
+    1: nrapply app_assoc.
+    lhs_V nrapply (ap (fun x => freegroup_eta (c ++ x))).
+    1: nrapply app_assoc.
+    lhs_V nrapply (ap (fun x => freegroup_eta (c ++ _ ++ x))).
+    1: nrapply app_assoc.
+    rhs_V nrapply ap.
+    2: nrapply app_assoc.
+    nrapply freegroup_tau.
   Defined.
 
   (** The unit of the free group is the empty word *)
-  Global Instance monunit_freegroup_type : MonUnit freegroup_type.
-  Proof.
-    apply freegroup_eta.
-    exact nil.
-  Defined.
+  Global Instance monunit_freegroup_type : MonUnit freegroup_type
+    := freegroup_eta nil.
 
   (** We can change the sign of all the elements in a word and reverse the order. This will be the inversion in the group *)
-  Fixpoint word_change_sign (x : Words) : Words.
-  Proof.
-    destruct x as [|x xs].
-    1: exact nil.
-    exact (word_change_sign xs @ [change_sign x]).
-  Defined.
+  Definition word_change_sign (x : Words) : Words
+    := reverse (list_map change_sign x).
 
   (** Changing the sign changes the order of word concatenation *)
   Definition word_change_sign_ww (x y : Words)
-    : word_change_sign (x @ y) = word_change_sign y @ word_change_sign x.
+    : word_change_sign (x ++ y) = word_change_sign y ++ word_change_sign x.
   Proof.
-    induction x.
-    { symmetry.
-      apply word_concat_w_nil. }
-    simpl.
-    refine (concat _ (inverse (word_concat_w_ww _ _ _))).
-    f_ap.
+    unfold word_change_sign.
+    lhs nrapply (ap reverse).
+    1: nrapply list_map_app.
+    nrapply reverse_app.
   Defined.
 
   (** This is also involutive *)
   Lemma word_change_sign_inv x : word_change_sign (word_change_sign x) = x.
   Proof.
-    induction x.
-    1: reflexivity.
-    simpl.
-    rewrite word_change_sign_ww.
-    cbn; f_ap.
+    unfold word_change_sign.
+    lhs_V nrapply list_map_reverse.
+    lhs nrapply ap.
+    1: nrapply reverse_reverse. 
+    lhs_V nrapply list_map_compose.
+    snrapply list_map_id.
+    intros a ?.
     apply change_sign_inv.
   Defined.
 
   (** Changing the sign gives us left inverses *)
-  Lemma word_concat_Vw x : freegroup_eta (word_change_sign x @ x) = mon_unit.
+  Lemma word_concat_Vw x : freegroup_eta (word_change_sign x ++ x) = mon_unit.
   Proof.
     induction x.
     1: reflexivity.
-    simpl.
+    lhs nrapply (ap (fun x => freegroup_eta (x ++ _))).
+    1: nrapply reverse_cons.
+    change (freegroup_eta ((word_change_sign x ++ [a^]) ++ [a] ++ x)
+      = mon_unit). 
+    lhs_V nrapply ap.
+    1: nrapply app_assoc.
     set (a' := a^).
     rewrite <- (change_sign_inv a).
-    change (freegroup_eta ((word_change_sign x @ [a']) @ ([a'^] @ x)) = mon_unit).
-    rewrite word_concat_w_ww.
-    rewrite freegroup_tau.
+    lhs nrapply freegroup_tau.
     apply IHx.
   Defined.
 
   (** And since changing the sign is involutive we get right inverses from left inverses *)
-  Lemma word_concat_wV x : freegroup_eta (x @ word_change_sign x) = mon_unit.
+  Lemma word_concat_wV x : freegroup_eta (x ++ word_change_sign x) = mon_unit.
   Proof.
     set (x' := word_change_sign x).
     rewrite <- (word_change_sign_inv x).
-    change (freegroup_eta (word_change_sign x' @ x') = mon_unit).
+    change (freegroup_eta (word_change_sign x' ++ x') = mon_unit).
     apply word_concat_Vw.
   Defined.
 
@@ -191,21 +174,20 @@ Section Reduction.
       exact (word_change_sign x). }
     intros [[b a] c].
     unfold map1, map2.
-    refine (concat _ (ap _ (inverse _))).
-    2: apply word_change_sign_ww.
-    refine (concat (ap _ _) _).
-    { refine (concat (word_change_sign_ww _ _) _).
-      apply ap.
-      refine (concat (ap _ (inverse (word_concat_w_ww _ _ _))) _).
-      refine (concat (word_change_sign_ww _ _) _).
-      rapply (ap (fun t => t @ word_change_sign b)).
-      apply word_change_sign_ww. }
-    refine (concat _ (freegroup_tau _ a _)).
-    apply ap.
-    refine (concat (word_concat_w_ww _ _ _) _); f_ap.
-    refine (concat (word_concat_w_ww _ _ _) _); f_ap.
-    f_ap; cbn; f_ap.
-    apply change_sign_inv.
+    lhs nrapply ap.
+    { lhs nrapply word_change_sign_ww.
+      nrapply (ap (fun x => x ++ _)). 
+      lhs nrapply word_change_sign_ww.
+      nrapply (ap (fun x => x ++ _)). 
+      lhs nrapply word_change_sign_ww.
+      nrapply (ap (fun x => _ ++ x)).
+      nrapply (word_change_sign_inv [a]). }
+    lhs_V nrapply ap.
+    1: rhs_V nrapply app_assoc.
+    1: nrapply app_assoc.
+    rhs nrapply ap.
+    2: nrapply word_change_sign_ww.
+    nrapply freegroup_tau.
   Defined.
 
   (** Now we can start to prove the group laws. Since these are hprops we can ignore what happens with the path constructor. *)
@@ -215,18 +197,18 @@ Section Reduction.
   Proof.
     intros x y z.
     strip_truncations.
-    revert x; snrapply Coeq_ind; intro x; [ | apply path_ishprop].
-    revert y; snrapply Coeq_ind; intro y; [ | apply path_ishprop].
-    revert z; snrapply Coeq_ind; intro z; [ | apply path_ishprop].
-    rapply (ap (tr o coeq)).
-    apply word_concat_w_ww.
+    revert x; srapply Coeq_ind_hprop; intro x.
+    revert y; srapply Coeq_ind_hprop; intro y.
+    revert z; srapply Coeq_ind_hprop; intro z.
+    nrapply (ap (tr o coeq)).
+    nrapply app_assoc.
   Defined.
 
   (** Left identity *)
   Global Instance leftidentity_freegroup_type : LeftIdentity sg_op mon_unit.
   Proof.
     rapply Trunc_ind.
-    srapply Coeq_ind; intro x; [ | apply path_ishprop].
+    srapply Coeq_ind_hprop; intros x.
     reflexivity.
   Defined.
 
@@ -234,16 +216,16 @@ Section Reduction.
   Global Instance rightidentity_freegroup_type : RightIdentity sg_op mon_unit.
   Proof.
     rapply Trunc_ind.
-    srapply Coeq_ind; intro x; [ | apply path_ishprop].
+    srapply Coeq_ind_hprop; intros x.
     apply (ap tr), ap.
-    apply word_concat_w_nil.
+    nrapply app_nil.
   Defined.
 
   (** Left inverse *)
   Global Instance leftinverse_freegroup_type : LeftInverse sg_op negate mon_unit.
   Proof.
     rapply Trunc_ind.
-    srapply Coeq_ind; intro x; [ | apply path_ishprop].
+    srapply Coeq_ind_hprop; intro x.
     apply word_concat_Vw.
   Defined.
 
@@ -251,7 +233,7 @@ Section Reduction.
   Global Instance rightinverse_freegroup_type : RightInverse sg_op negate mon_unit.
   Proof.
     rapply Trunc_ind.
-    srapply Coeq_ind; intro x; [ | apply path_ishprop].
+    srapply Coeq_ind_hprop; intro x.
     apply word_concat_wV.
   Defined.
 
@@ -260,43 +242,66 @@ Section Reduction.
   Proof.
     snrapply (Build_Group freegroup_type); repeat split; exact _.
   Defined.
+  
+  Definition word_rec (G : Group) (s : A -> G) : A + A -> G.
+  Proof.
+    intros [x|x].
+    - exact (s x).
+    - exact (- s x).
+  Defined.
 
+  (** When we have a list of words we can recursively define a group element. The obvious choice would be to map [nil] to the identity and [x :: xs] to [x * words_rec xs]. This has the disadvantage that a single generating element gets mapped to [x * 1] instead of [x]. To fix this issue, we map [nil] to the identity, the singleton to the element we want, and do the rest recursively. *)
   Definition words_rec (G : Group) (s : A -> G) : Words -> G.
   Proof.
-    intro x.
-    induction x as [|x xs].
-    1: exact mon_unit.
-    refine (_ * IHxs).
-    destruct x as [x|x].
-    1: exact (s x).
-    exact (- s x).
+    intro xs.
+    induction xs as [|x [|y xs] IHxs].
+    - exact mon_unit.
+    - exact (word_rec G s x).
+    - exact (word_rec G s x * IHxs).
+  Defined.
+
+  Definition words_rec_cons (G : Group) (s : A -> G) (x : A + A) (xs : Words)
+    : words_rec G s (x :: xs)%list = word_rec G s x * words_rec G s xs.
+  Proof.
+    induction xs in x |- *.
+    - symmetry; nrapply grp_unit_r.
+    - reflexivity.
   Defined.
 
   Lemma words_rec_pp (G : Group) (s : A -> G)  (x y : Words)
-    : words_rec G s (x @ y) = words_rec G s x * words_rec G s y.
+    : words_rec G s (x ++ y) = words_rec G s x * words_rec G s y.
   Proof.
-    induction x.
-    1: symmetry; apply left_identity.
-    cbn; rewrite <- simple_associativity.
-    f_ap.
+    induction x as [|x xs IHxs] in y |- *.
+    - symmetry; nrapply grp_unit_l.
+    - change ((?x :: ?xs) ++ y) with (x :: xs ++ y).
+      lhs nrapply words_rec_cons.
+      lhs nrapply ap.
+      1: nrapply IHxs.
+      lhs nrapply grp_assoc.
+      nrapply (ap (.* _)).
+      symmetry.
+      apply words_rec_cons.
   Defined.
 
   Lemma words_rec_coh (G : Group) (s : A -> G) (a : A + A) (b c : Words)
     : words_rec G s (map1 (b, a, c)) = words_rec G s (map2 (b, a, c)).
   Proof.
     unfold map1, map2.
-    refine (concat _ (words_rec_pp G s _ _)^).
-    refine (concat (words_rec_pp G s _ _) _); f_ap.
-    refine (concat _ (right_identity _)).
-    refine (concat (ap _ (word_concat_w_ww _ _ _)^) _).
-    refine (concat (words_rec_pp G s _ _) _); f_ap.
-    refine (concat (concat (simple_associativity _ _ _) _) (left_identity mon_unit)).
-    destruct a; simpl; f_ap.
-    + apply right_inverse.
-    + apply left_inverse.
+    rhs nrapply (words_rec_pp G s).
+    lhs nrapply words_rec_pp.
+    nrapply (ap (_ *.)).
+    lhs nrapply words_rec_pp.
+    lhs nrapply ap.
+    1: nrapply words_rec_pp.
+    lhs nrapply grp_assoc.
+    rhs_V nrapply grp_unit_l.
+    nrapply (ap (.* _)).
+    destruct a; simpl.
+    - nrapply grp_inv_r.
+    - nrapply grp_inv_l.
   Defined.
 
-  (** Given a group [G] we can construct a group homomorphism [FreeGroup A -> G] if we have a map [A -> G] *)
+  (** Given a group [G] we can construct a group homomorphism [FreeGroup A -> G] if we have a map [A -> G]. *)
   Definition FreeGroup_rec (G : Group) (s : A -> G)
     : GroupHomomorphism FreeGroup G.
   Proof.
@@ -307,57 +312,88 @@ Section Reduction.
       intros [[b a] c].
       apply words_rec_coh. }
     intros x y; strip_truncations.
-    revert x; snrapply Coeq_ind; hnf; intro x; [ | apply path_ishprop ].
-    revert y; snrapply Coeq_ind; hnf; intro y; [ | apply path_ishprop ].
+    revert x; srapply Coeq_ind_hprop; intro x.
+    revert y; srapply Coeq_ind_hprop; intro y. 
     simpl.
     apply words_rec_pp.
   Defined.
 
+  Definition freegroup_in : A -> FreeGroup
+    := freegroup_eta o (fun x => [ x ]) o inl.
+
+  Definition FreeGroup_rec_beta {G : Group} (f : A -> G)
+    : FreeGroup_rec _ f o freegroup_in == f
+    := fun _ => idpath.
+
+  Coercion freegroup_in : A >-> group_type.
+  
+  Definition FreeGroup_ind_hprop' (P : FreeGroup -> Type)
+    `{forall x, IsHProp (P x)}
+    (H1 : forall w, P (freegroup_eta w))
+    : forall x, P x.
+  Proof.
+    rapply Trunc_ind.
+    srapply Coeq_ind_hprop.
+    exact H1.
+  Defined.
+ 
+  Definition FreeGroup_ind_hprop (P : FreeGroup -> Type)
+    `{forall x, IsHProp (P x)}
+    (H1 : P mon_unit)
+    (Hin : forall x, P (freegroup_in x))
+    (Hop : forall x y, P x -> P y -> P (- x * y))
+    : forall x, P x.
+  Proof.
+    rapply FreeGroup_ind_hprop'.
+    intros w.
+    induction w as [|a w IHw].
+    - exact H1.
+    - destruct a as [a|a].
+      + change (P ((freegroup_in a) * freegroup_eta w)).  
+        rewrite <- (grp_inv_inv a).
+        apply Hop.
+        * rewrite <- grp_unit_r.
+          by apply Hop.
+        * assumption.
+      + change (P (-(freegroup_in a) * freegroup_eta w)).
+        by apply Hop.
+  Defined.
+  
+  Definition FreeGroup_ind_homotopy {G : Group} {f f' : FreeGroup $-> G}
+    (H : forall x, f (freegroup_in x) = f' (freegroup_in x))
+    : f $== f'.
+  Proof.
+    rapply FreeGroup_ind_hprop.
+    - exact (concat (grp_homo_unit f) (grp_homo_unit f')^).
+    - exact H.
+    - intros x y p q. refine (grp_homo_op_agree f f' _ q).
+      lhs nrapply grp_homo_inv.
+      rhs nrapply grp_homo_inv.
+      exact (ap _ p).
+  Defined.
+
   (** Now we need to prove that the free group satisifes the unviersal property of the free group. *)
   (** TODO: remove funext from here and universal property of free group *)
   Global Instance isfreegroupon_freegroup `{Funext}
-    : IsFreeGroupOn A FreeGroup (freegroup_eta o word_sing o inl).
+    : IsFreeGroupOn A FreeGroup freegroup_in.
   Proof.
     intros G f.
     snrapply Build_Contr.
     { srefine (_;_); simpl.
       1: apply FreeGroup_rec, f.
-      intro x; simpl.
-      apply right_identity. }
+      intro x; reflexivity. }
     intros [g h].
     nrapply path_sigma_hprop; [ exact _ |].
     simpl.
     apply equiv_path_grouphomomorphism.
-    intro x.
-    rewrite <- (path_forall _ _ h).
-    strip_truncations; revert x.
-    snrapply Coeq_ind; intro x; [|apply path_ishprop].
-    hnf; symmetry.
-    induction x.
-    1: apply (grp_homo_unit g).
-    refine (concat (grp_homo_op g (freegroup_eta [a]) (freegroup_eta x)) _).
-    simpl.
-    f_ap.
-    destruct a.
-    1: reflexivity.
-    exact (grp_homo_inv g (freegroup_eta [inl a])).
+    symmetry.
+    snrapply FreeGroup_ind_homotopy.
+    exact h.
   Defined.
 
   (** Typeclass search can already find this but we leave it here as a definition for reference. *)
   Definition isfreegroup_freegroup `{Funext} : IsFreeGroup FreeGroup := _.
 
-  Definition freegroup_in : A -> FreeGroup
-    := freegroup_eta o word_sing o inl.
-
-  Lemma FreeGroup_rec_beta {G : Group} (f : A -> G)
-    : FreeGroup_rec _ f o freegroup_in == f.
-  Proof.
-    intros x.
-    apply grp_unit_r.
-  Defined.
-
-  Coercion freegroup_in : A >-> group_type.
-
 End Reduction.
 
 Arguments freegroup_eta {A}.
@@ -428,7 +464,7 @@ Proof.
   intros k G g.
   specialize (k G).
   snrapply contr_equiv'.
-  1: exact (hfiber (fun f x => grp_homo_map F G f (i x)) g).
+  1: exact (hfiber (fun f x => grp_homo_map f (i x)) g).
   { rapply equiv_functor_sigma_id.
     intro y; symmetry.
     apply equiv_path_forall. }
@@ -478,7 +514,7 @@ Section FreeGroupGenerated.
     snrapply issurj_retr.
     - apply to_subgroup_generated.
     - apply ap10; cbn.
-      exact (ap (grp_homo_map F_S F_S) (is_retraction)).
+      exact (ap grp_homo_map is_retraction).
   Defined.
 
   (* Therefore, the inclusion map is an equivalence, since it is known to be an embedding. *)
@@ -499,3 +535,26 @@ Section FreeGroupGenerated.
   Defined.
 
 End FreeGroupGenerated.
+
+(** ** Functoriality *)
+
+Global Instance is0functor_freegroup : Is0Functor FreeGroup.
+Proof.
+  snrapply Build_Is0Functor.
+  intros X Y f.
+  snrapply FreeGroup_rec.
+  exact (freegroup_in o f).
+Defined.
+
+Global Instance is1functor_freegroup : Is1Functor FreeGroup.
+Proof.
+  snrapply Build_Is1Functor.
+  - intros X Y f g p.
+    snrapply FreeGroup_ind_homotopy.
+    intros x.
+    exact (ap freegroup_in (p x)).
+  - intros X.
+    by snrapply FreeGroup_ind_homotopy.
+  - intros X Y Z f g.
+    by snrapply FreeGroup_ind_homotopy.
+Defined.
diff --git a/theories/Algebra/Groups/FreeProduct.v b/theories/Algebra/Groups/FreeProduct.v
index 3c4c1fe093b..ce8667ba763 100644
--- a/theories/Algebra/Groups/FreeProduct.v
+++ b/theories/Algebra/Groups/FreeProduct.v
@@ -1,6 +1,6 @@
 Require Import Basics Types.
 Require Import Cubical.
-Require Import Spaces.List.
+Require Import Spaces.List.Core Spaces.List.Theory.
 Require Import Colimits.Pushout.
 Require Import Truncations.Core Truncations.SeparatedTrunc.
 Require Import Algebra.Groups.Group.
@@ -38,27 +38,6 @@ Section FreeProduct.
 
   Local Definition Words : Type := list (H + K).
 
-  Local Notation "[ x ]" := (cons x nil).
-
-  Local Definition word_concat_w_nil (x : Words) : x ++ nil = x.
-  Proof.
-    induction x; trivial.
-    cbn; f_ap.
-  Defined.
-
-  Local Definition word_concat_w_ww (x y z : Words) : x ++ (y ++ z) = (x ++ y) ++ z.
-  Proof.
-    revert x z.
-    induction y; intros x z.
-    { f_ap; symmetry.
-      apply word_concat_w_nil. }
-    simpl; revert z y IHy.
-    induction x; trivial.
-    intros z y IHy.
-    simpl; f_ap.
-    apply IHx, IHy.
-  Defined.
-
   Local Fixpoint word_inverse (x : Words) : Words.
   Proof.
     destruct x as [|x xs].
@@ -73,10 +52,9 @@ Section FreeProduct.
     : word_inverse (x ++ y) = word_inverse y ++ word_inverse x.
   Proof.
     induction x as [|x xs].
-    { symmetry.
-      apply word_concat_w_nil. }
+    1: symmetry; apply app_nil.
     simpl.
-    destruct x; refine (_ @ (word_concat_w_ww _ _ _)^); f_ap.
+    destruct x; rhs nrapply app_assoc; f_ap.
   Defined.
 
 
@@ -242,7 +220,6 @@ Section FreeProduct.
     snrapply Coeq_ind.
     1: exact e.
     intro a.
-    nrapply dp_path_transport^-1%equiv.
     destruct a as [ [ [ [a | a ] | a] | a ] | a ].
     + destruct a as [[[x h1] h2] y].
       apply dp_compose.
@@ -267,7 +244,7 @@ Section FreeProduct.
   Proof.
     srapply amal_type_ind.
     1: exact e.
-    all: intros; apply dp_path_transport, path_ishprop.
+    all: intros; apply path_ishprop.
   Defined.
 
   (** From which we can derive the non-dependent eliminator / recursion principle *)
@@ -304,23 +281,23 @@ Section FreeProduct.
       1: exact (amal_eta (x ++ y)).
       { intros z h1 h2.
         refine (ap amal_eta _ @ _ @ ap amal_eta _^).
-        1,3: apply word_concat_w_ww.
+        1,3: apply app_assoc.
         rapply amal_mu_H. }
       { intros z k1 k2.
         refine (ap amal_eta _ @ _ @ ap amal_eta _^).
-        1,3: apply word_concat_w_ww.
+        1,3: apply app_assoc.
         rapply amal_mu_K. }
       { intros w z.
         refine (ap amal_eta _ @ _ @ ap amal_eta _^).
-        1,3: apply word_concat_w_ww.
+        1,3: apply app_assoc.
         apply amal_tau. }
       { intros z.
         refine (ap amal_eta _ @ _ @ ap amal_eta _^).
-        1,3: apply word_concat_w_ww.
+        1,3: apply app_assoc.
         apply amal_omega_H. }
       { intros z.
         refine (ap amal_eta _ @ _ @ ap amal_eta _^).
-        1,3: apply word_concat_w_ww.
+        1,3: apply app_assoc.
         apply amal_omega_K. } }
     { intros r y h1 h2; revert r.
       rapply amal_type_ind_hprop.
@@ -328,9 +305,9 @@ Section FreeProduct.
       change (amal_eta ((x ++ ((inl h1 :: [inl h2]) ++ y)) ++ z)
         = amal_eta ((x ++ [inl (h1 * h2)] ++ y) ++ z)).
       refine (ap amal_eta _^ @ _ @ ap amal_eta _).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       refine (ap amal_eta (ap (app x) _)^ @ _ @ ap amal_eta (ap (app x) _)).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       apply amal_mu_H. }
     { intros r y k1 k2; revert r.
       rapply amal_type_ind_hprop.
@@ -338,9 +315,9 @@ Section FreeProduct.
       change (amal_eta ((x ++ ((inr k1 :: [inr k2]) ++ y)) ++ z)
         = amal_eta ((x ++ [inr (k1 * k2)] ++ y) ++ z)).
       refine (ap amal_eta _^ @ _ @ ap amal_eta _).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       refine (ap amal_eta (ap (app x) _)^ @ _ @ ap amal_eta (ap (app x) _)).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       apply amal_mu_K. }
     { intros r y z; revert r.
       rapply amal_type_ind_hprop.
@@ -348,27 +325,27 @@ Section FreeProduct.
       change (amal_eta ((x ++ [inl (f z)] ++ y) ++ w)
         = amal_eta ((x ++ [inr (g z)] ++ y) ++ w)).
       refine (ap amal_eta _^ @ _ @ ap amal_eta _).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       refine (ap amal_eta (ap (app x) _)^ @ _ @ ap amal_eta (ap (app x) _)).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       apply amal_tau. }
     { intros r z; revert r.
       rapply amal_type_ind_hprop.
       intros w;
       change (amal_eta ((x ++ [inl mon_unit] ++ z) ++ w) = amal_eta ((x ++ z) ++ w)).
       refine (ap amal_eta _^ @ _ @ ap amal_eta _).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       refine (ap amal_eta (ap (app x) _)^ @ _).
-      1: apply word_concat_w_ww.
+      1: apply app_assoc.
       apply amal_omega_H. }
     { intros r z; revert r.
       rapply amal_type_ind_hprop.
       intros w;
       change (amal_eta ((x ++ [inr mon_unit] ++ z) ++ w) = amal_eta ((x ++ z) ++ w)).
       refine (ap amal_eta _^ @ _ @ ap amal_eta _).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       refine (ap amal_eta (ap (app x) _)^ @ _).
-      1: apply word_concat_w_ww.
+      1: apply app_assoc.
       apply amal_omega_K. }
   Defined.
 
@@ -394,7 +371,7 @@ Section FreeProduct.
         apply negate_sg_op. }
       simpl.
       refine (ap amal_eta _^ @ _ @ ap amal_eta _).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       apply amal_mu_H. }
     { hnf; intros x y k1 k2.
       refine (ap amal_eta _ @ _ @ ap amal_eta _^).
@@ -407,7 +384,7 @@ Section FreeProduct.
         apply negate_sg_op. }
       simpl.
       refine (ap amal_eta _^ @ _ @ ap amal_eta _).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       apply amal_mu_K. }
     { hnf; intros x y z.
       refine (ap amal_eta _ @ _ @ ap amal_eta _^).
@@ -417,7 +394,7 @@ Section FreeProduct.
       1,2: apply ap.
       1,2: symmetry; apply grp_homo_inv.
       refine (ap amal_eta _^ @ _ @ ap amal_eta _).
-      1,3: apply word_concat_w_ww.
+      1,3: apply app_assoc.
       apply amal_tau. }
     { hnf; intros x z.
       refine (ap amal_eta _ @ _ @ ap amal_eta _^).
@@ -426,7 +403,7 @@ Section FreeProduct.
       { refine (ap (fun s => s ++ _) _).
         apply word_inverse_ww. }
       refine (ap amal_eta _^ @ _).
-      1: apply word_concat_w_ww.
+      1: apply app_assoc.
       simpl.
       rewrite negate_mon_unit.
       apply amal_omega_H. }
@@ -437,7 +414,7 @@ Section FreeProduct.
       { refine (ap (fun s => s ++ _) _).
         apply word_inverse_ww. }
       refine (ap amal_eta _^ @ _).
-      1: apply word_concat_w_ww.
+      1: apply app_assoc.
       simpl.
       rewrite negate_mon_unit.
       apply amal_omega_K. }
@@ -450,7 +427,7 @@ Section FreeProduct.
     rapply amal_type_ind_hprop; intro y; revert x.
     rapply amal_type_ind_hprop; intro x.
     nrapply (ap amal_eta).
-    rapply word_concat_w_ww.
+    rapply app_assoc.
   Defined.
 
   Global Instance leftidentity_sgop_amal_type : LeftIdentity sg_op mon_unit.
@@ -463,7 +440,7 @@ Section FreeProduct.
   Proof.
     rapply amal_type_ind_hprop; intro x.
     nrapply (ap amal_eta).
-    apply word_concat_w_nil.
+    nrapply app_nil.
   Defined.
 
   Lemma amal_eta_word_concat_Vw (x : Words) : amal_eta (word_inverse x ++ x) = mon_unit.
@@ -473,14 +450,14 @@ Section FreeProduct.
     destruct x as [h|k].
     + change (amal_eta (word_inverse ([inl h] ++ xs) ++ [inl h] ++ xs) = mon_unit).
       rewrite word_inverse_ww.
-      rewrite <- word_concat_w_ww.
+      rewrite <- app_assoc.
       refine (amal_mu_H _ _ _ _ @ _).
       rewrite left_inverse.
       rewrite amal_omega_H.
       apply IHxs.
     + change (amal_eta (word_inverse ([inr k] ++ xs) ++ [inr k] ++ xs) = mon_unit).
       rewrite word_inverse_ww.
-      rewrite <- word_concat_w_ww.
+      rewrite <- app_assoc.
       refine (amal_mu_K _ _ _ _ @ _).
       rewrite left_inverse.
       rewrite amal_omega_K.
@@ -493,13 +470,13 @@ Section FreeProduct.
     1: reflexivity.
     destruct x as [h|k].
     + cbn.
-      rewrite word_concat_w_ww.
+      rewrite app_assoc.
       change (amal_eta ([inl h]) * amal_eta ((xs ++ word_inverse xs)) * amal_eta ([inl (- h)]) = mon_unit).
       rewrite IHxs.
       rewrite rightidentity_sgop_amal_type.
-      rewrite <- (word_concat_w_nil (cons _ _)).
+      rewrite <- (app_nil (cons _ _)).
       change (amal_eta (([inl h] ++ [inl (- h)]) ++ nil) = mon_unit).
-      rewrite <- word_concat_w_ww.
+      rewrite <- app_assoc.
       change (amal_eta (nil ++ [inl h] ++ [inl (- h)] ++ nil) = mon_unit).
       refine (amal_mu_H _ _ _ _ @ _).
       refine (_ @ _).
@@ -510,13 +487,13 @@ Section FreeProduct.
         apply right_inverse. }
       apply amal_omega_H.
     +  cbn.
-      rewrite word_concat_w_ww.
+      rewrite app_assoc.
       change (amal_eta ([inr k]) * amal_eta ((xs ++ word_inverse xs)) * amal_eta ([inr (-k)]) = mon_unit).
       rewrite IHxs.
       rewrite rightidentity_sgop_amal_type.
-      rewrite <- (word_concat_w_nil (cons _ _)).
+      rewrite <- (app_nil (cons _ _)).
       change (amal_eta (([inr k] ++ [inr (- k)]) ++ nil) = mon_unit).
-      rewrite <- word_concat_w_ww.
+      rewrite <- app_assoc.
       change (amal_eta (nil ++ [inr k] ++ [inr (- k)] ++ nil) = mon_unit).
       refine (amal_mu_K _ _ _ _ @ _).
       refine (_ @ _).
@@ -553,7 +530,7 @@ Section FreeProduct.
   Proof.
     srapply amal_type_rec.
     { intro w.
-      refine (fold_right _ _ _ _ w).
+      refine (fold_right _ _ w).
       { intros [l|r] x.
         + exact (h l * x).
         + exact (k r * x). }
@@ -595,7 +572,7 @@ Section FreeProduct.
     intros x; srapply amal_type_ind_hprop; intro y; revert x;
     srapply amal_type_ind_hprop; intro x; simpl.
     rewrite fold_right_app.
-    set (s := (fold_right X (H + K)
+    set (s := (fold_right
      (fun X0 : H + K => match X0 with
                         | inl l => fun x0 : X => h l * x0
                         | inr r => fun x0 : X => k r * x0
@@ -623,9 +600,9 @@ Section FreeProduct.
     { intro x.
       exact (amal_eta [inl x]). }
     intros x y.
-    rewrite <- (word_concat_w_nil [inl (x * y)]).
+    rewrite <- (app_nil [inl (x * y)]).
     rewrite <- (amal_mu_H nil nil x y).
-    rewrite word_concat_w_nil.
+    rewrite app_nil.
     reflexivity.
   Defined.
 
@@ -635,9 +612,9 @@ Section FreeProduct.
     { intro x.
       exact (amal_eta [inr x]). }
     intros x y.
-    rewrite <- (word_concat_w_nil [inr (x * y)]).
+    rewrite <- (app_nil [inr (x * y)]).
     rewrite <- (amal_mu_K nil nil x y).
-    rewrite word_concat_w_nil.
+    rewrite app_nil.
     reflexivity.
   Defined.
 
@@ -653,8 +630,8 @@ Section FreeProduct.
       intro x.
       apply (ap r).
       simpl.
-      rewrite <- (word_concat_w_nil [inl (f x)]).
-      rewrite <- (word_concat_w_nil [inr (g x)]).
+      rewrite <- (app_nil [inl (f x)]).
+      rewrite <- (app_nil [inr (g x)]).
       apply (amal_tau nil nil x). }
     { intros r.
       apply equiv_path_grouphomomorphism.
@@ -731,10 +708,9 @@ Proof.
     intros w.
     induction w as [|gh].
     1: exact (grp_homo_unit _ @ (grp_homo_unit _)^).
-    Local Notation "[ x ]" := (cons x nil).
     change (f (amal_eta [gh] * amal_eta w) = g (amal_eta [gh] * amal_eta w)).
-    refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^).
-    f_ap; clear IHw w.
+    nrapply grp_homo_op_agree.
+    2: apply IHw.
     destruct gh as [g' | h].
     + exact (p g').
     + exact (q h).
diff --git a/theories/Algebra/Groups/Group.v b/theories/Algebra/Groups/Group.v
index e4789ffc04b..b72ef628198 100644
--- a/theories/Algebra/Groups/Group.v
+++ b/theories/Algebra/Groups/Group.v
@@ -1,6 +1,6 @@
 Require Import Basics Types HProp HFiber HSet.
 Require Import PathAny.
-Require Import (notations) Classes.interfaces.abstract_algebra.
+Require Import (notations) Classes.interfaces.canonical_names.
 Require Export (hints) Classes.interfaces.abstract_algebra.
 Require Export (hints) Classes.interfaces.canonical_names.
 (** We only export the parts of these that will be most useful to users of this file. *)
@@ -17,7 +17,7 @@ Require Export Classes.interfaces.abstract_algebra (IsGroup(..), group_monoid, n
 Require Export Classes.theory.groups.
 Require Import Pointed.Core.
 Require Import WildCat.
-Require Import Spaces.Nat.Core.
+Require Import Spaces.Nat.Core Spaces.Int.
 Require Import Truncations.Core.
 
 Local Set Polymorphic Inductive Cumulativity.
@@ -26,21 +26,23 @@ Generalizable Variables G H A B C f g.
 
 Declare Scope group_scope.
 
-(** ** Groups *)
+(** * Groups *)
+
+(** A group is an abstraction of several common situations in mathematics. For example, consider the symmetries of an object.  Two symmetries can be combined; there is a symmetry that does nothing; and any symmetry can be reversed. Such situations arise in geometry, algebra and, importantly for us, homotopy theory. *)
 
 Local Open Scope pointed_scope.
 Local Open Scope mc_mult_scope.
 Local Open Scope wc_iso_scope.
 
-(** * Definition of Group *)
+(** ** Definition of a Group *)
 
 (** A group consists of a type, an operation on that type, a unit and an inverse that satisfy the group axioms in [IsGroup]. *)
 Record Group := {
-  group_type : Type;
-  group_sgop : SgOp group_type;
-  group_unit : MonUnit group_type;
-  group_inverse : Negate group_type;
-  group_isgroup : IsGroup group_type;
+  group_type :> Type;
+  group_sgop :: SgOp group_type;
+  group_unit :: MonUnit group_type;
+  group_inverse :: Negate group_type;
+  group_isgroup :: IsGroup group_type;
 }.
 
 Arguments group_sgop {_}.
@@ -50,15 +52,11 @@ Arguments group_isgroup {_}.
 (** We should never need to unfold the proof that something is a group. *)
 Global Opaque group_isgroup.
 
-(** We coerce groups back to types. *)
-Coercion group_type : Group >-> Sortclass.
-Global Existing Instances group_sgop group_unit group_inverse group_isgroup.
-
 Definition issig_group : _ <~> Group
   := ltac:(issig).
 
-(** * Proof automation *)
-(** Many times in group theoretic proofs we want some form of automation for obvious identities. Here we implement such a behaviour. *)
+(** ** Proof automation *)
+(** Many times in group theoretic proofs we want some form of automation for obvious identities. Here we implement such a behavior. *)
 
 (** We create a database of hints for the group theory library *)
 Create HintDb group_db.
@@ -90,16 +88,16 @@ End GroupLaws.
 (** TODO: improve this tactic so that it also rewrites and is able to solve basic group lemmas. *)
 Tactic Notation "grp_auto" := hnf; intros; eauto with group_db.
 
+(** ** Some basic properties of groups *)
+
 (** Groups are pointed sets with point the identity. *)
 Global Instance ispointed_group (G : Group)
   : IsPointed G := @mon_unit G _.
 
 Definition ptype_group : Group -> pType
   := fun G => [G, _].
-Coercion ptype_group : Group >-> pType.
-
-(** * Some basic properties of groups *)
 
+Coercion ptype_group : Group >-> pType.
 (** An element acting like the identity is unique. *)
 Definition identity_unique {A : Type} {Aop : SgOp A}
   (x y : A) {p : LeftIdentity Aop x} {q : RightIdentity Aop y}
@@ -122,24 +120,60 @@ Defined.
 
 (** ** Group homomorphisms *)
 
-(* A group homomorphism consists of a map between groups and a proof that the map preserves the group operation. *)
-Record GroupHomomorphism (G H : Group) := Build_GroupHomomorphism' {
-  grp_homo_map : G -> H;
-  grp_homo_ishomo :> IsMonoidPreserving grp_homo_map;
+(** Group homomorphisms are maps between groups that preserve the group operation. They allow us to compare groups and map their structure to one another. This is useful for determining if two groups are really the same, in which case we say they are "isomorphic". *)
+
+(** A group homomorphism consists of a map between groups and a proof that the map preserves the group operation. *)
+Record GroupHomomorphism (G H : Group) := Build_GroupHomomorphism {
+  grp_homo_map :> group_type G -> group_type H;
+  issemigrouppreserving_grp_homo :: IsSemiGroupPreserving grp_homo_map;
 }.
 
-(* We coerce a homomorphism to its underlying map. *)
-Coercion grp_homo_map : GroupHomomorphism >-> Funclass.
-Global Existing Instance grp_homo_ishomo.
+Arguments grp_homo_map {G H}.
+Arguments Build_GroupHomomorphism {G H} _ _.
+Arguments issemigrouppreserving_grp_homo {G H} f _ : rename.
+
+(** ** Basic properties of group homomorphisms *)
+
+(** Group homomorphisms preserve group operations. This is an alias for [issemigrouppreserving_grp_homo] with the identity written explicitly. *)
+Definition grp_homo_op
+  : forall {G H : Group} (f : GroupHomomorphism G H) (x y : G), f (x * y) = f x * f y
+  := @issemigrouppreserving_grp_homo.
+#[export] Hint Immediate grp_homo_op : group_db.
+
+(** Group homomorphisms are unit preserving. *)
+Global Instance isunitpreserving_grp_homo {G H : Group}
+  (f : GroupHomomorphism G H)
+  : IsUnitPreserving f.
+Proof.
+  unfold IsUnitPreserving.
+  apply (group_cancelL (f mon_unit)).
+  rhs nrapply grp_unit_r.
+  rhs_V rapply (ap  _ (monoid_left_id _ mon_unit)).
+  symmetry.
+  nrapply issemigrouppreserving_grp_homo.
+Defined.
+
+(** Group homomorphisms preserve identities. This is an alias for the previous statement. *)
+Definition grp_homo_unit
+  : forall {G H : Group} (f : GroupHomomorphism G H), f mon_unit = mon_unit
+  := @isunitpreserving_grp_homo.
+#[export] Hint Immediate grp_homo_unit : group_db.
+
+(** Therefore, group homomorphisms are monoid homomorphisms. *)
+Global Instance ismonoidpreserving_grp_homo {G H : Group}
+  (f : GroupHomomorphism G H)
+  : IsMonoidPreserving f
+  := {}.
 
-(* Group homomorphisms are pointed maps *)
+(** Group homomorphisms are pointed maps. *)
 Definition pmap_GroupHomomorphism {G H : Group} (f : GroupHomomorphism G H) : G ->* H
-  := Build_pMap G H f (@monmor_unitmor _ _ _ _ _ _ _ (@grp_homo_ishomo G H f)).
+  := Build_pMap G H f (isunitpreserving_grp_homo f).
 Coercion pmap_GroupHomomorphism : GroupHomomorphism >-> pForall.
 
 Definition issig_GroupHomomorphism (G H : Group) : _ <~> GroupHomomorphism G H
   := ltac:(issig).
 
+(** Function extensionality for group homomorphisms. *)
 Definition equiv_path_grouphomomorphism {F : Funext} {G H : Group}
   {g h : GroupHomomorphism G H} : g == h <~> g = h.
 Proof.
@@ -148,6 +182,7 @@ Proof.
   apply equiv_path_forall.
 Defined.
 
+(** Group homomorphisms are sets, in the presence of funext. *)
 Global Instance ishset_grouphomomorphism {F : Funext} {G H : Group}
   : IsHSet (GroupHomomorphism G H).
 Proof.
@@ -155,25 +190,7 @@ Proof.
   intros f g; apply (istrunc_equiv_istrunc _ equiv_path_grouphomomorphism).
 Defined.
 
-(** * Some basic properties of group homomorphisms *)
-
-(** Group homomorphisms preserve identities *)
-Definition grp_homo_unit {G H} (f : GroupHomomorphism G H)
-  : f (mon_unit) = mon_unit.
-Proof.
-  apply monmor_unitmor.
-Defined.
-#[export] Hint Immediate grp_homo_unit : group_db.
-
-(** Group homomorphisms preserve group operations *)
-Definition grp_homo_op {G H} (f : GroupHomomorphism G H)
-  : forall x y : G, f (x * y) = f x * f y.
-Proof.
-  apply monmor_sgmor.
-Defined.
-#[export] Hint Immediate grp_homo_op : group_db.
-
-(** Group homomorphisms preserve inverses *)
+(** Group homomorphisms preserve inverses. *)
 Definition grp_homo_inv {G H} (f : GroupHomomorphism G H)
   : forall x, f (- x) = -(f x).
 Proof.
@@ -187,25 +204,11 @@ Proof.
 Defined.
 #[export] Hint Immediate grp_homo_inv : group_db.
 
-(** When building a group homomorphism we only need that it preserves the group operation, since we can prove that the identity is preserved. *)
-Definition Build_GroupHomomorphism {G H : Group}
-  (f : G -> H) {h : IsSemiGroupPreserving f}
-  : GroupHomomorphism G H.
-Proof.
-  srapply (Build_GroupHomomorphism' _ _ f).
-  split.
-  1: exact h.
-  unfold IsUnitPreserving.
-  apply (group_cancelL (f mon_unit)).
-  refine (_ @ (grp_unit_r _)^).
-  refine (_ @ ap _ (monoid_left_id _ mon_unit)).
-  symmetry.
-  apply h.
-Defined.
-
+(** The identity map is a group homomorphism. *)
 Definition grp_homo_id {G : Group} : GroupHomomorphism G G
-  := Build_GroupHomomorphism idmap.
+  := Build_GroupHomomorphism idmap _.
 
+(** The composition of the underlying functions of two group homomorphisms is also a group homomorphism. *)
 Definition grp_homo_compose {G H K : Group}
   : GroupHomomorphism H K -> GroupHomomorphism G H -> GroupHomomorphism G K.
 Proof.
@@ -213,21 +216,17 @@ Proof.
   srapply (Build_GroupHomomorphism (f o g)).
 Defined.
 
-Definition grp_homo_const {G H : Group} : GroupHomomorphism G H.
-Proof.
-  snrapply Build_GroupHomomorphism.
-  - exact (fun _ => mon_unit).
-  - intros x y.
-    exact (grp_unit_l mon_unit)^.
-Defined.
+(** ** Group Isomorphisms *)
+
+(** Group isomorphsims are group homomorphisms whose underlying map happens to be an equivalence. They allow us to consider two groups to be the "same". They can be inverted and composed just like equivalences. *)
 
-(* An isomorphism of groups is a group homomorphism that is an equivalence. *)
+(** An isomorphism of groups is defined as group homomorphism that is an equivalence. *)
 Record GroupIsomorphism (G H : Group) := Build_GroupIsomorphism {
-  grp_iso_homo : GroupHomomorphism G H;
-  isequiv_group_iso : IsEquiv grp_iso_homo;
+  grp_iso_homo :> GroupHomomorphism G H;
+  isequiv_group_iso :: IsEquiv grp_iso_homo;
 }.
 
-(* We can build an isomorphism from an operation preserving equivalence. *)
+(** We can build an isomorphism from an operation-preserving equivalence. *)
 Definition Build_GroupIsomorphism' {G H : Group}
   (f : G <~> H) (h : IsSemiGroupPreserving f)
   : GroupIsomorphism G H.
@@ -237,23 +236,22 @@ Proof.
   exact _.
 Defined.
 
-Coercion grp_iso_homo : GroupIsomorphism >-> GroupHomomorphism.
-Global Existing Instance isequiv_group_iso.
-
 Definition issig_GroupIsomorphism (G H : Group)
   : _ <~> GroupIsomorphism G H := ltac:(issig).
 
+(** The underlying equivalence of a group isomorphism. *)
 Definition equiv_groupisomorphism {G H : Group}
   : GroupIsomorphism G H -> G <~> H
   := fun f => Build_Equiv G H f _.
+Coercion equiv_groupisomorphism : GroupIsomorphism >-> Equiv.
 
+(** The underlying pointed equivalence of a group isomorphism. *)
 Definition pequiv_groupisomorphism {A B : Group}
   : GroupIsomorphism A B -> (A <~>* B)
   := fun f => Build_pEquiv _ _ f _.
-
-Coercion equiv_groupisomorphism : GroupIsomorphism >-> Equiv.
 Coercion pequiv_groupisomorphism : GroupIsomorphism >-> pEquiv.
 
+(** Funext for group isomorphisms. *)
 Definition equiv_path_groupisomorphism `{F : Funext} {G H : Group}
   (f g : GroupIsomorphism G H)
   : f == g <~> f = g.
@@ -263,6 +261,7 @@ Proof.
   apply equiv_path_grouphomomorphism.
 Defined.
 
+(** Group isomorphisms form a set. *)
 Definition ishset_groupisomorphism `{F : Funext} {G H : Group}
   : IsHSet (GroupIsomorphism G H).
 Proof.
@@ -270,14 +269,17 @@ Proof.
   intros f g; apply (istrunc_equiv_istrunc _ (equiv_path_groupisomorphism _ _)).
 Defined.
 
+(** The identity map is an equivalence and therefore a group isomorphism. *)
 Definition grp_iso_id {G : Group} : GroupIsomorphism G G
   := Build_GroupIsomorphism _ _ grp_homo_id _.
 
+(** Group isomorphisms can be composed by composing the underlying group homomorphism. *)
 Definition grp_iso_compose {G H K : Group}
   (g : GroupIsomorphism H K) (f : GroupIsomorphism G H)
   : GroupIsomorphism G K
   := Build_GroupIsomorphism _ _ (grp_homo_compose g f) _.
 
+(** Group isomorphisms can be inverted. The inverse map of the underlying equivalence also preserves the group operation and unit. *)
 Definition grp_iso_inverse {G H : Group}
   : GroupIsomorphism G H -> GroupIsomorphism H G.
 Proof.
@@ -287,64 +289,56 @@ Proof.
   - exact _.
 Defined.
 
-(** Group Isomorphisms are a reflexive relation *)
+(** Group isomorphism is a reflexive relation. *)
 Global Instance reflexive_groupisomorphism
   : Reflexive GroupIsomorphism
   := fun G => grp_iso_id.
 
-(** Group Isomorphisms are a symmetric relation *)
+(** Group isomorphism is a symmetric relation. *)
 Global Instance symmetric_groupisomorphism
   : Symmetric GroupIsomorphism
   := fun G H => grp_iso_inverse.
 
+(** Group isomorphism is a transitive relation. *)
 Global Instance transitive_groupisomorphism
   : Transitive GroupIsomorphism
   := fun G H K f g => grp_iso_compose g f.
 
-(** Under univalence, equality of groups is equivalent to isomorphism of groups. *)
+(** Under univalence, equality of groups is equivalent to isomorphism of groups. This is the structure identity principle for groups. *)
 Definition equiv_path_group' {U : Univalence} {G H : Group}
   : GroupIsomorphism G H <~> G = H.
 Proof.
-  refine (equiv_compose'
-    (B := sig (fun f : G <~> H => IsMonoidPreserving f)) _ _).
-  { revert G H; apply (equiv_path_issig_contr issig_group).
-    + intros [G [? [? [? ?]]]].
-      exists 1%equiv.
-      exact _.
-    + intros [G [op [unit [neg ax]]]]; cbn.
-      contr_sigsig G (equiv_idmap G).
-      srefine (Build_Contr _ ((_;(_;(_;_)));_) _); cbn.
-      1: assumption.
-      1: exact _.
-      intros [[op' [unit' [neg' ax']]] eq].
-      apply path_sigma_hprop; cbn.
-      refine (@ap _ _ (fun x : { oun :
-        { oo : SgOp G & { u : MonUnit G & Negate G}}
-        & @IsGroup G oun.1 oun.2.1 oun.2.2}
-        => (x.1.1 ; x.1.2.1 ; x.1.2.2 ; x.2))
-        ((op;unit;neg);ax) ((op';unit';neg');ax') _).
-      apply path_sigma_hprop; cbn.
-      srefine (path_sigma' _ _ _).
-      1: funext x y; apply eq.
-      rewrite transport_const.
-      srefine (path_sigma' _ _ _).
-      1: apply eq.
-      rewrite transport_const.
-      funext x.
-      exact (preserves_negate (f:=idmap) _). }
-  refine (_ oE (issig_GroupIsomorphism G H)^-1).
-  refine (_ oE (equiv_functor_sigma' (issig_GroupHomomorphism G H)
-    (fun f => 1%equiv))^-1).
-  refine (equiv_functor_sigma' (issig_equiv G H) (fun f => 1%equiv) oE _).
-  cbn.
-  refine (
-    equiv_adjointify
-      (fun f => (exist (IsMonoidPreserving o pr1)
-        (exist IsEquiv f.1.1 f.2) f.1.2))
-      (fun f => (exist (IsEquiv o pr1)
-        (exist IsMonoidPreserving f.1.1 f.2) f.1.2))
-       _ _).
-  all: intros [[]]; reflexivity.
+  equiv_via {f : G <~> H & IsSemiGroupPreserving f}.
+  1: make_equiv.
+  revert G H; apply (equiv_path_issig_contr issig_group).
+  - intros [G [? [? [? ?]]]].
+    exists 1%equiv.
+    exact _.
+  - intros [G [op [unit [neg ax]]]]; cbn.
+    contr_sigsig G (equiv_idmap G).
+    srefine (Build_Contr _ ((_;(_;(_;_)));_) _); cbn.
+    1: assumption.
+    1: exact _.
+    intros [[op' [unit' [neg' ax']]] eq].
+    apply path_sigma_hprop; cbn.
+    refine (@ap _ _ (fun x : { oun :
+      { oo : SgOp G & { u : MonUnit G & Negate G}}
+      & @IsGroup G oun.1 oun.2.1 oun.2.2}
+      => (x.1.1 ; x.1.2.1 ; x.1.2.2 ; x.2))
+      ((op;unit;neg);ax) ((op';unit';neg');ax') _).
+    apply path_sigma_hprop; cbn.
+    srefine (path_sigma' _ _ _).
+    1: funext x y; apply eq.
+    rewrite transport_const.
+    pose (f := Build_GroupHomomorphism
+        (G:=Build_Group G op unit neg ax)
+        (H:=Build_Group G op' unit' neg' ax')
+        idmap eq).
+    srefine (path_sigma' _ _ _).
+    1: exact (grp_homo_unit f).
+    lhs nrapply transport_const.
+    funext x.
+    exact (grp_homo_inv f x).
 Defined.
 
 (** A version with nicer universe variables. *)
@@ -352,9 +346,9 @@ Definition equiv_path_group@{u v | u < v} {U : Univalence} {G H : Group@{u}}
   : GroupIsomorphism G H <~> (paths@{v} G H)
   := equiv_path_group'.
 
-(** * Simple group equivalences *)
+(** ** Simple group equivalences *)
 
-(** Left multiplication is an equivalence *)
+(** Left multiplication is an equivalence. *)
 Global Instance isequiv_group_left_op {G : Group}
   : forall (x : G), IsEquiv (x *.).
 Proof.
@@ -368,7 +362,7 @@ Proof.
   apply grp_inv_l.
 Defined.
 
-(** Right multiplication is an equivalence *)
+(** Right multiplication is an equivalence. *)
 Global Instance isequiv_group_right_op (G : Group)
   : forall (x : G), IsEquiv (fun y => y * x).
 Proof.
@@ -382,6 +376,7 @@ Proof.
   apply grp_inv_r.
 Defined.
 
+(** The operation inverting group elements is an equivalence. Note that, since the order of the operation will change after inversion, this isn't a group homomorphism. *)
 Global Instance isequiv_group_inverse {G : Group}
   : IsEquiv ((-) : G -> G).
 Proof.
@@ -390,21 +385,24 @@ Proof.
   all: intro; apply negate_involutive.
 Defined.
 
-(** ** Working with equations in groups *)
+(** ** Reasoning with equations in groups. *)
 
 Section GroupEquations.
 
   Context {G : Group} (x y z : G).
 
-  (** Inverses are involutive *)
+  (** Inverses are involutive. *)
   Definition grp_inv_inv : --x = x := negate_involutive x.
 
-  (** Inverses distribute over the group operation *)
+  (** Inverses distribute over the group operation. *)
   Definition grp_inv_op : - (x * y) = -y * -x := negate_sg_op x y.
+  
+  (** The inverse of the unit is the unit. *)
+  Definition grp_inv_unit : -mon_unit = mon_unit := negate_mon_unit (G :=G).
 
 End GroupEquations.
 
-(** ** Cancelation *)
+(** ** Cancelation lemmas *)
 
 (** Group elements can be cancelled both on the left and the right. *)
 Definition grp_cancelL {G : Group} {x y : G} z : x = y <~> z * x = z * y
@@ -459,6 +457,9 @@ Section GroupMovement.
 
   Definition grp_moveL_1M : x * -y = mon_unit <~> x = y
     := equiv_concat_r (grp_unit_l _) _ oE grp_moveL_gM.
+  
+  Definition grp_moveL_1V : x * y = mon_unit <~> x = -y
+    := equiv_concat_r (grp_unit_l _) _ oE grp_moveL_gV.
 
   Definition grp_moveL_M1 : -y * x = mon_unit <~> x = y
     := equiv_concat_r (grp_unit_r _) _ oE grp_moveL_Mg.
@@ -479,44 +480,203 @@ Section GroupMovement.
 
 End GroupMovement.
 
-(** Power operation *)
+(** ** Commutation *)
+
+(** If [g] commutes with [h], then [g] commutes with the inverse [-h]. *)
+Definition grp_commutes_inv {G : Group} (g h : G) (p : g * h = h * g)
+  : g * (-h) = (-h) * g.
+Proof.
+  apply grp_moveR_gV.
+  rhs_V apply simple_associativity.
+  by apply grp_moveL_Vg.
+Defined.
+
+(** If [g] commutes with [h] and [h'], then [g] commutes with their product [h * h']. *)
+Definition grp_commutes_op {G : Group} (g h h' : G)
+  (p : g * h = h * g) (p' : g * h' = h' * g)
+  : g * (h * h') = (h * h') * g.
+Proof.
+  lhs apply simple_associativity.
+  lhs nrapply (ap (.* h') p).
+  lhs_V apply simple_associativity.
+  lhs nrapply (ap (h *.) p').
+  by apply simple_associativity.
+Defined.
+
+(** ** Power operation *)
+
+(** For a given [g : G] we can define the function [Int -> G] sending an integer to that power of [g]. *)
+Definition grp_pow {G : Group} (g : G) (n : Int) : G
+  := int_iter (g *.) n mon_unit.
+
+(** Any homomorphism respects [grp_pow]. In other words, [fun g => grp_pow g n] is natural. *)
+Lemma grp_pow_natural {G H : Group} (f : GroupHomomorphism G H) (n : Int) (g : G)
+  : f (grp_pow g n) = grp_pow (f g) n.
+Proof.
+  lhs snrapply (int_iter_commute_map _ ((f g) *.)).
+  1: nrapply grp_homo_op.
+  apply (ap (int_iter _ n)), grp_homo_unit.
+Defined.
+
+(** All powers of the unit are the unit. *)
+Definition grp_pow_unit {G : Group} (n : Int)
+  : grp_pow (G:=G) mon_unit n = mon_unit.
+Proof.
+  snrapply (int_iter_invariant n _ (fun g => g = mon_unit)); cbn.
+  1, 2: apply paths_ind_r.
+  - apply grp_unit_r.
+  - lhs nrapply grp_unit_r. apply grp_inv_unit.
+  - reflexivity.
+Defined.
+
+(** Note that powers don't preserve the group operation as it is not commutative. This does hold in an abelian group so such a result will appear later. *)
+
+(** The next two results tell us how [grp_pow] unfolds. *)
+Definition grp_pow_succ {G : Group} (n : Int) (g : G)
+  : grp_pow g (n.+1)%int = g * grp_pow g n
+  := int_iter_succ_l _ _ _.
+
+Definition grp_pow_pred {G : Group} (n : Int) (g : G)
+  : grp_pow g (n.-1)%int = (- g) * grp_pow g n
+  := int_iter_pred_l _ _ _.
+
+(** [grp_pow] satisfies an additive law of exponents. *)
+Definition grp_pow_add {G : Group} (m n : Int) (g : G)
+  : grp_pow g (n + m)%int = grp_pow g n * grp_pow g m.
+Proof.
+  lhs nrapply int_iter_add.
+  induction n; cbn.
+  1: exact (grp_unit_l _)^.
+  1: rewrite int_iter_succ_l, grp_pow_succ.
+  2: rewrite int_iter_pred_l, grp_pow_pred; cbn.
+  1,2 : rhs_V srapply associativity;
+        apply ap, IHn.
+Defined.
+
+(** [grp_pow] commutes negative exponents to powers of the inverse *)
+Definition grp_pow_neg {G : Group} (n : Int) (g : G)
+  : grp_pow g (int_neg n) = grp_pow (- g) n.
+Proof.
+  lhs nrapply int_iter_neg.
+  cbn; unfold grp_pow.
+  (* These agree, except for the proofs that [sg_op (-g)] is an equivalence. *)
+  apply int_iter_agree.
+Defined.
+
+(** Using a negative power in [grp_pow] is the same as first using a positive power and then inverting the result. *)
+Definition grp_pow_neg_inv {G: Group} (m : Int) (g : G) : grp_pow g (- m)%int = - grp_pow g m.
+Proof.
+  apply grp_moveL_1V.
+  lhs_V nrapply grp_pow_add.
+  by rewrite int_add_neg_l.
+Defined.
+
+(** Combining the two previous results gives that a power of an inverse is the inverse of the power. *)
+Definition grp_pow_neg_inv' {G: Group} (n: Int) (g : G) : grp_pow (- g) n = - grp_pow g n.
+Proof.
+  lhs_V nrapply grp_pow_neg.
+  apply grp_pow_neg_inv.
+Defined.
+
+(** [grp_pow] satisfies a multiplicative law of exponents. *)
+Definition grp_pow_int_mul {G : Group} (m n : Int) (g : G)
+  : grp_pow g (m * n)%int = grp_pow (grp_pow g m) n.
+Proof.
+  induction n.
+  - simpl.
+    by rewrite int_mul_0_r.
+  - rewrite int_mul_succ_r.
+    rewrite grp_pow_add.
+    rewrite grp_pow_succ.
+    apply grp_cancelL, IHn.
+  - rewrite int_mul_pred_r.
+    rewrite grp_pow_add.
+    rewrite grp_pow_neg_inv.
+    rewrite grp_pow_pred.
+    apply grp_cancelL, IHn.
+Defined.
+
+(** If [h] commutes with [g], then [h] commutes with [grp_pow g n]. *)
+Definition grp_pow_commutes {G : Group} (n : Int) (g h : G)
+  (p : h * g = g * h)
+  : h * (grp_pow g n) = (grp_pow g n) * h.
+Proof.
+  induction n.
+  - exact (grp_unit_r _ @ (grp_unit_l _)^).
+  - rewrite grp_pow_succ.
+    nrapply grp_commutes_op; assumption.
+  - rewrite grp_pow_pred.
+    nrapply grp_commutes_op.
+    2: assumption.
+    apply grp_commutes_inv, p.
+Defined.
 
-Definition grp_pow {G : Group} (g : G) (n : nat) : G := nat_iter n (g *.) mon_unit.
+(** [grp_pow g n] commutes with [g]. *)
+Definition grp_pow_commutes' {G : Group} (n : Int) (g : G)
+  : g * grp_pow g n = grp_pow g n * g.
+Proof.
+  by apply grp_pow_commutes.
+Defined.
 
-(** Any homomorphism respects [grp_pow]. *)
-Lemma grp_pow_homo {G H : Group} (f : GroupHomomorphism G H)
-  (n : nat) (g : G) : f (grp_pow g n) = grp_pow (f g) n.
+(** If [g] and [h] commute, then [grp_pow (g * h) n] = (grp_pow g n) * (grp_pow h n)]. *)
+Definition grp_pow_mul {G : Group} (n : Int) (g h : G)
+  (c : g * h = h * g)
+  : grp_pow (g * h) n = (grp_pow g n) * (grp_pow h n).
 Proof.
   induction n.
-  + cbn. apply grp_homo_unit.
-  + cbn. refine ((grp_homo_op f g (grp_pow g n)) @ _).
-    exact (ap (fun m => f g + m) IHn).
+  - simpl.
+    symmetry; nrapply grp_unit_r.
+  - rewrite 3 grp_pow_succ.
+    rewrite IHn.
+    rewrite 2 grp_assoc.
+    apply grp_cancelR.
+    rewrite <- 2 grp_assoc.
+    apply grp_cancelL.
+    apply grp_pow_commutes.
+    exact c^.
+  - simpl.
+    rewrite 3 grp_pow_pred.
+    rewrite IHn.
+    rewrite 2 grp_assoc.
+    apply grp_cancelR.
+    rewrite c.
+    rewrite grp_inv_op.
+    rewrite <- 2 grp_assoc.
+    apply grp_cancelL.
+    apply grp_pow_commutes.
+    symmetry; apply grp_commutes_inv, c.
 Defined.
 
-(** The wild cat of Groups *)
+(** ** The category of Groups *)
+
+(** ** Groups together with homomorphisms form a 1-category whose equivalences are the group isomorphisms. *)
+
 Global Instance isgraph_group : IsGraph Group
   := Build_IsGraph Group GroupHomomorphism.
 
 Global Instance is01cat_group : Is01Cat Group :=
   Build_Is01Cat Group _ (@grp_homo_id) (@grp_homo_compose).
 
+(** Helper notation so that the wildcat instances can easily be inferred. *)
+Local Notation grp_homo_map' A B := (@grp_homo_map A B : _ -> (group_type A $-> _)).
+
 Global Instance is2graph_group : Is2Graph Group
-  := fun A B => isgraph_induced (@grp_homo_map A B).
+  := fun A B => isgraph_induced (grp_homo_map' A B).
 
 Global Instance isgraph_grouphomomorphism {A B : Group} : IsGraph (A $-> B)
-  := isgraph_induced (@grp_homo_map A B).
+  := isgraph_induced (grp_homo_map' A B).
 
 Global Instance is01cat_grouphomomorphism {A B : Group} : Is01Cat (A $-> B)
-  := is01cat_induced (@grp_homo_map A B).
+  := is01cat_induced (grp_homo_map' A B).
 
 Global Instance is0gpd_grouphomomorphism {A B : Group}: Is0Gpd (A $-> B)
-  := is0gpd_induced (@grp_homo_map A B).
+  := is0gpd_induced (grp_homo_map' A B).
 
 Global Instance is0functor_postcomp_grouphomomorphism {A B C : Group} (h : B $-> C)
   : Is0Functor (@cat_postcomp Group _ _ A B C h).
 Proof.
   apply Build_Is0Functor.
-  intros [f ?] [g ?] p a ; exact (ap h (p a)).
+  intros f g p a ; exact (ap h (p a)).
 Defined.
 
 Global Instance is0functor_precomp_grouphomomorphism
@@ -533,6 +693,7 @@ Proof.
   by rapply Build_Is1Cat.
 Defined.
 
+(** Under [Funext], the category of groups has morphism extensionality. *)
 Global Instance hasmorext_group `{Funext} : HasMorExt Group.
 Proof.
   srapply Build_HasMorExt.
@@ -543,6 +704,7 @@ Proof.
   intros []; reflexivity. 
 Defined.
 
+(** Group isomorphisms become equivalences in the category of groups. *)
 Global Instance hasequivs_group
   : HasEquivs Group.
 Proof.
@@ -566,12 +728,21 @@ Proof.
   all: intros; apply equiv_path_grouphomomorphism; intro; reflexivity.
 Defined.
 
+(** The [group_type] map is a 1-functor. *)
+
 Global Instance is0functor_type_group : Is0Functor group_type.
 Proof.
   apply Build_Is0Functor.
   rapply @grp_homo_map.
 Defined.
 
+Global Instance is1functor_type_group : Is1Functor group_type.
+Proof.
+  by apply Build_Is1Functor.
+Defined.
+
+(** The [ptype_group] map is a 1-functor. *)
+
 Global Instance is0functor_ptype_group : Is0Functor ptype_group.
 Proof.
   apply Build_Is0Functor.
@@ -580,9 +751,7 @@ Defined.
 
 Global Instance is1functor_ptype_group : Is1Functor ptype_group.
 Proof.
-  apply Build_Is1Functor; intros; apply phomotopy_homotopy_hset.
-  1: assumption.
-  1, 2: reflexivity.
+  apply Build_Is1Functor; intros; by apply phomotopy_homotopy_hset.
 Defined.
 
 (** Given a group element [a0 : A] over [b : B], multiplication by [a] establishes an equivalence between the kernel and the fiber over [b]. *)
@@ -607,7 +776,7 @@ Proof.
   repeat split; try exact _; by intros [].
 Defined.
 
-(** Map out of trivial group *)
+(** Map out of trivial group. *)
 Definition grp_trivial_rec (G : Group) : GroupHomomorphism grp_trivial G.
 Proof.
   snrapply Build_GroupHomomorphism.
@@ -615,7 +784,7 @@ Proof.
   intros ??; symmetry; apply grp_unit_l.
 Defined.
 
-(** Map into trivial group *)
+(** Map into trivial group. *)
 Definition grp_trivial_corec (G : Group) : GroupHomomorphism G grp_trivial.
 Proof.
   snrapply Build_GroupHomomorphism.
@@ -623,8 +792,27 @@ Proof.
   intros ??; symmetry; exact (grp_unit_l _).
 Defined.
 
-(** * Direct product of group *)
+(** Group is a pointed category. *)
+Global Instance ispointedcat_group : IsPointedCat Group.
+Proof.
+  snrapply Build_IsPointedCat.
+  - exact grp_trivial.
+  - intro G.
+    exists (grp_trivial_rec G).
+    intros g []; cbn.
+    exact (grp_homo_unit g)^.
+  - intro G.
+    exists (grp_trivial_corec G).
+    intros g x; cbn.
+    apply path_unit.
+Defined.
+
+Definition grp_homo_const {G H : Group} : GroupHomomorphism G H
+  := zero_morphism.
+
+(** ** The direct product of groups *)
 
+(** The cartesian product of the underlying sets of two groups has a natural group structure. We call this the direct product of groups. *)
 Definition grp_prod : Group -> Group -> Group.
 Proof.
   intros G H.
@@ -642,38 +830,28 @@ Proof.
   all: grp_auto.
 Defined.
 
-Proposition grp_prod_corec {G H K : Group}
-            (f : GroupHomomorphism K G)
-            (g : GroupHomomorphism K H)
-  : GroupHomomorphism K (grp_prod G H).
+(** Maps into the direct product can be built by mapping separately into each factor. *)
+Proposition grp_prod_corec {G H K : Group} (f : K $-> G) (g : K $-> H)
+  : K $-> (grp_prod G H).
 Proof.
   snrapply Build_GroupHomomorphism.
-  - exact (fun x:K => (f x, g x)).
+  - exact (fun x : K => (f x, g x)).
   - intros x y.
-    refine (path_prod' _ _ ); try apply grp_homo_op.
+    apply path_prod'; apply grp_homo_op.
 Defined.
 
+(** [grp_prod_corec] satisfies a definitional naturality property. *)
+Definition grp_prod_corec_natural {X Y A B : Group}
+  (f : X $-> Y) (g0 : Y $-> A) (g1 : Y $-> B)
+  : grp_prod_corec g0 g1 $o f $== grp_prod_corec (g0 $o f) (g1 $o f)
+  := fun _ => idpath.
+
+(** The left factor injects into the direct product. *)
 Definition grp_prod_inl {H K : Group}
-  : GroupHomomorphism H (grp_prod H K)
+  : H $-> (grp_prod H K)
   := grp_prod_corec grp_homo_id grp_homo_const.
 
-Definition grp_prod_inr {H K : Group}
-  : GroupHomomorphism K (grp_prod H K)
-  := grp_prod_corec grp_homo_const grp_homo_id.
-
-Definition grp_iso_prod {A B C D : Group}
-  : A ≅ B -> C ≅ D -> (grp_prod A C) ≅ (grp_prod B D).
-Proof.
-  intros f g.
-  srapply Build_GroupIsomorphism'.
-  1: srapply (equiv_functor_prod (f:=f) (g:=g)).
-  simpl.
-  unfold functor_prod.
-  intros x y.
-  apply path_prod.
-  1,2: apply grp_homo_op.
-Defined.
-
+(** The left injection is an embedding. *)
 Global Instance isembedding_grp_prod_inl {H K : Group}
   : IsEmbedding (@grp_prod_inl H K).
 Proof.
@@ -682,6 +860,12 @@ Proof.
   exact (fst ((equiv_path_prod _ _)^-1 p)).
 Defined.
 
+(** The right factor injects into the direct product. *)
+Definition grp_prod_inr {H K : Group}
+  : K $-> (grp_prod H K)
+  := grp_prod_corec grp_homo_const grp_homo_id.
+
+(** The right injection is an embedding. *)
 Global Instance isembedding_grp_prod_inr {H K : Group}
   : IsEmbedding (@grp_prod_inr H K).
 Proof.
@@ -690,6 +874,21 @@ Proof.
   exact (snd ((equiv_path_prod _ _)^-1 q)).
 Defined.
 
+(** Given two pairs of isomorphic groups, their pairwise direct products are isomorphic. *)
+Definition grp_iso_prod {A B C D : Group}
+  : A ≅ B -> C ≅ D -> (grp_prod A C) ≅ (grp_prod B D).
+Proof.
+  intros f g.
+  srapply Build_GroupIsomorphism'.
+  1: srapply (equiv_functor_prod (f:=f) (g:=g)).
+  simpl.
+  unfold functor_prod.
+  intros x y.
+  apply path_prod.
+  1,2: apply grp_homo_op.
+Defined.
+
+(** The first projection of the direct product. *)
 Definition grp_prod_pr1 {G H : Group}
   : GroupHomomorphism (grp_prod G H) G.
 Proof.
@@ -698,6 +897,12 @@ Proof.
   intros ? ?; reflexivity.
 Defined.
 
+(** The first projection is a surjection. *)
+Global Instance issurj_grp_prod_pr1 {G H : Group}
+  : IsSurjection (@grp_prod_pr1 G H)
+  := issurj_retr grp_prod_inl (fun _ => idpath).
+
+(** The second projection of the direct product. *)
 Definition grp_prod_pr2 {G H : Group}
   : GroupHomomorphism (grp_prod G H) H.
 Proof.
@@ -706,14 +911,21 @@ Proof.
   intros ? ?; reflexivity.
 Defined.
 
-Global Instance issurj_grp_prod_pr1 {G H : Group}
-  : IsSurjection (@grp_prod_pr1 G H)
-  := issurj_retr grp_prod_inl (fun _ => idpath).
+(** Pairs in direct products can be decomposed *)
+Definition grp_prod_decompose {G H : Group} (g : G) (h : H)
+  : (g, h) = ((g, group_unit) : grp_prod G H) * (group_unit, h).
+Proof.
+  snrapply path_prod; symmetry.
+  - snrapply grp_unit_r.
+  - snrapply grp_unit_l.
+Defined.
 
+(** The second projection is a surjection. *)
 Global Instance issurj_grp_prod_pr2 {G H : Group}
   : IsSurjection (@grp_prod_pr2 G H)
   := issurj_retr grp_prod_inr (fun _ => idpath).
 
+(** [Group] is a category with binary products given by the direct product. *)
 Global Instance hasbinaryproducts_group : HasBinaryProducts Group.
 Proof.
   intros G H.
@@ -792,7 +1004,7 @@ Class IsFreeGroupOn (S : Type) (F_S : Group) (i : S -> F_S)
       Contr (FactorsThroughFreeGroup S F_S i A g).
 Global Existing Instance contr_isfreegroupon.
 
-(** A group is free if there exists a generating type on which it is a free group *)
+(** A group is free if there exists a generating type on which it is a free group. *)
 Class IsFreeGroup (F_S : Group)
   := isfreegroup : {S : _ & {i : _ & IsFreeGroupOn S F_S i}}.
 
@@ -801,6 +1013,9 @@ Global Instance isfreegroup_isfreegroupon (S : Type) (F_S : Group) (i : S -> F_S
   : IsFreeGroup F_S
   := (S; i; H).
 
+
+(** ** Further properties of group homomorphisms. *)
+
 (** Characterisation of injective group homomorphisms. *)
 Lemma isembedding_grouphomomorphism {A B : Group} (f : A $-> B)
   : (forall a, f a = group_unit -> a = group_unit) <-> IsEmbedding f.
@@ -832,3 +1047,26 @@ Proof.
   refine (ap f _).
   apply C.
 Defined.
+
+(** If two group homomorphisms agree on two elements, then they agree on their product. *)
+Definition grp_homo_op_agree {G G' H : Group} (f : G $-> H) (f' : G' $-> H)
+  {x y : G} {x' y' : G'} (p : f x = f' x') (q : f y = f' y')
+  : f (x * y) = f' (x' * y').
+Proof.
+  lhs nrapply grp_homo_op.
+  rhs nrapply grp_homo_op.
+  exact (ap011 _ p q).
+Defined.
+
+(** The group movement lemmas can be extended to when there is a homomorphism involved.  For now, we only include these two. *)
+Definition grp_homo_moveL_1V {A B : Group} (f : GroupHomomorphism A B) (x y : A)
+  : f (x * y) = group_unit <~> (f x = - f y)
+  := grp_moveL_1V oE equiv_concat_l (grp_homo_op f x y)^ _.
+
+Definition grp_homo_moveL_1M  {A B : Group} (f : GroupHomomorphism A B) (x y : A)
+  : f (x * -y) = group_unit <~> (f x = f y).
+Proof.
+  refine (grp_moveL_1M oE equiv_concat_l _^ _).
+  lhs nrapply grp_homo_op.
+  apply ap, grp_homo_inv.
+Defined.
diff --git a/theories/Algebra/Groups/GroupCoeq.v b/theories/Algebra/Groups/GroupCoeq.v
index 92d1d1a8b80..3986a7c7484 100644
--- a/theories/Algebra/Groups/GroupCoeq.v
+++ b/theories/Algebra/Groups/GroupCoeq.v
@@ -34,15 +34,14 @@ Proof.
     refine (p _ @ _).
     revert x.
     rapply Trunc_ind.
-    srapply Coeq_ind.
-    2: intros; apply path_ishprop.
+    srapply Coeq_ind_hprop.
     intros w. hnf.
     induction w.
     1: apply ap, grp_homo_unit.
     simpl.
     destruct a as [a|a].
     1,2: refine (ap _ (grp_homo_op _ _ _) @ _).
-    1,2: refine (grp_homo_op _ _ _ @ _ @ (grp_homo_op _ _ _)^); f_ap.
+    1,2: nrapply grp_homo_op_agree; trivial.
     symmetry.
     apply p. }
   { intros [k p] x.
diff --git a/theories/Algebra/Groups/GrpPullback.v b/theories/Algebra/Groups/GrpPullback.v
index c3c3dca73c3..13b19e43bc3 100644
--- a/theories/Algebra/Groups/GrpPullback.v
+++ b/theories/Algebra/Groups/GrpPullback.v
@@ -16,9 +16,7 @@ Section GrpPullback.
   Proof.
     intros [b [c p]] [d [e q]].
     refine (b * d; c * e; _).
-    refine (grp_homo_op f b d @ (_ @ _) @ (grp_homo_op g c e)^).
-    - exact (ap (fun y:A => f b * y) q).
-    - exact (ap (fun x:A => x * g e) p).
+    exact (grp_homo_op_agree _ _ p q).
   Defined.
 
   Local Instance grp_pullback_sgop_associative
diff --git a/theories/Algebra/Groups/Image.v b/theories/Algebra/Groups/Image.v
index 2b3f9e11187..6ce4afc4f3e 100644
--- a/theories/Algebra/Groups/Image.v
+++ b/theories/Algebra/Groups/Image.v
@@ -13,19 +13,16 @@ Local Open Scope mc_mult_scope.
 (** The image of a group homomorphism between groups is a subgroup *)
 Definition grp_image {A B : Group} (f : A $-> B) : Subgroup B.
 Proof.
-  snrapply (Build_Subgroup _ (fun b => hexists (fun a => f a = b))).
-  repeat split.
-  1: exact _.
-  1: apply tr; exists mon_unit; apply grp_homo_unit.
-  { intros x y p q; strip_truncations; apply tr.
-    destruct p as [a []], q as [b []].
-    exists (a * b).
-    apply grp_homo_op. }
-  intros b p.
-  strip_truncations.
-  destruct p as [a []].
-  apply tr; exists (- a).
-  apply grp_homo_inv.
+  snrapply (Build_Subgroup' (fun b => hexists (fun a => f a = b))).
+  - exact _.
+  - apply tr.
+    exists mon_unit.
+    apply grp_homo_unit.
+  - intros x y p q; strip_truncations; apply tr.
+    destruct p as [a p], q as [b q].
+    exists (a * -b).
+    lhs nrapply grp_homo_op; f_ap.
+    lhs nrapply grp_homo_inv; f_ap.
 Defined.
 
 Definition grp_image_in {A B : Group} (f : A $-> B) : A $-> grp_image f.
diff --git a/theories/Algebra/Groups/Kernel.v b/theories/Algebra/Groups/Kernel.v
index e4e2d0b25b8..2d418803558 100644
--- a/theories/Algebra/Groups/Kernel.v
+++ b/theories/Algebra/Groups/Kernel.v
@@ -11,19 +11,17 @@ Local Open Scope mc_mult_scope.
 Definition grp_kernel {A B : Group} (f : GroupHomomorphism A B) : NormalSubgroup A.
 Proof.
   snrapply Build_NormalSubgroup.
-  - srapply (Build_Subgroup' (fun x => f x = group_unit)).
+  - srapply (Build_Subgroup' (fun x => f x = group_unit)); cbn beta.
     1: apply grp_homo_unit.
-    intros x y p q; cbn in p, q; cbn.
-    refine (grp_homo_op _ _ _ @ ap011 _ p _ @ _).
-    1: apply grp_homo_inv.
-    rewrite q; apply right_inverse.
-  - intros x y; cbn.
-    rewrite 2 grp_homo_op.
-    rewrite 2 grp_homo_inv.
-    refine (_^-1 oE grp_moveL_M1).
-    refine (_ oE equiv_path_inverse _ _).
-    apply grp_moveR_1M.
-  Defined.
+    intros x y p q.
+    apply (grp_homo_moveL_1M _ _ _)^-1.
+    exact (p @ q^).
+  - intros x y; cbn; intros p.
+    apply (grp_homo_moveL_1V _ _ _)^-1.
+    lhs_V nrapply grp_inv_inv.
+    apply (ap (-)).
+    exact ((grp_homo_moveL_1V f x y) p)^.
+Defined.
 
 (** ** Corecursion principle for group kernels *)
 
diff --git a/theories/Algebra/Groups/Presentation.v b/theories/Algebra/Groups/Presentation.v
index 18d99526b76..0a1a7b2b182 100644
--- a/theories/Algebra/Groups/Presentation.v
+++ b/theories/Algebra/Groups/Presentation.v
@@ -3,7 +3,7 @@ Require Import Truncations.Core.
 Require Import Algebra.Groups.Group.
 Require Import Algebra.Groups.FreeGroup.
 Require Import Algebra.Groups.GroupCoeq.
-Require Import Spaces.Finite.
+Require Import Spaces.Finite Spaces.List.Core.
 Require Import WildCat.
 
 
@@ -92,32 +92,13 @@ Proof.
   intros f.
   srapply equiv_iff_hprop.
   { intros p.
-    hnf.
-    rapply Trunc_ind.
-    srapply Coeq.Coeq_ind.
-    2: intros; apply path_ishprop.
-    intros w; hnf.
-    induction w.
-    1: reflexivity.
-    simpl.
-    refine (_ @ _ @ _^).
-    1,3: exact (grp_homo_op (FreeGroup_rec _ _ _) _ _).
-    f_ap.
-    destruct a.
-    1: refine (p _ @ (grp_homo_unit _)^).
-    refine (grp_homo_inv _ _ @ ap _ _ @ (grp_homo_inv _ _)^).
-    refine (p _ @ (grp_homo_unit _)^). }
+    change (equiv_freegroup_rec H _ f $o FreeGroup_rec _ _ (gp_relators P)
+      $== equiv_freegroup_rec _ _ f $o FreeGroup_rec _ _ (fun _ => group_unit)).
+    rapply FreeGroup_ind_homotopy.
+    exact p. }
   intros p r.
   hnf in p.
-  pose (p' := p o freegroup_eta).
-  clearbody p'; clear p.
-  specialize (p' (FreeGroup.word_sing _ (inl r))).
-  refine (_ @ p').
-  clear p'.
-  symmetry.
-  refine (grp_homo_op _ _ _ @ _).
-  refine (_ @ right_identity _).
-  f_ap.
+  exact (p (freegroup_in r)).
 Defined.
 
 (** ** Constructors for finite presentations *)
diff --git a/theories/Algebra/Groups/QuotientGroup.v b/theories/Algebra/Groups/QuotientGroup.v
index 802a6ff18d7..91c0c3396f1 100644
--- a/theories/Algebra/Groups/QuotientGroup.v
+++ b/theories/Algebra/Groups/QuotientGroup.v
@@ -19,31 +19,20 @@ Local Open Scope wc_iso_scope.
 
 Section GroupCongruenceQuotient.
 
-  Context {G : Group} {R : Relation G}
-    `{is_mere_relation _ R, !IsCongruence R,
-      !Reflexive R, !Symmetric R, !Transitive R}.
+  (** A congruence on a group is a relation satisfying [R x x' -> R y y' -> R (x * y) (x' * y')].  Because we also require that [R] is reflexive, we also know that [R y y' -> R (x * y) (x * y')] for any [x], and similarly for multiplication on the right by [x].  We don't need to assume that [R] is symmetric or transitive. *)
+  Context {G : Group} {R : Relation G} `{!IsCongruence R, !Reflexive R}.
 
+  (** The type underlying the quotient group is [Quotient R]. *)
   Definition CongruenceQuotient := G / R.
 
   Global Instance congquot_sgop : SgOp CongruenceQuotient.
   Proof.
-    intros x.
-    srapply Quotient_rec.
-    { intro y; revert x.
-      srapply Quotient_rec.
-      { intros x.
-        apply class_of.
-        exact (x * y). }
-      intros a b r.
-      cbn.
+    srapply Quotient_rec2.
+    - intros x y.
+      exact (class_of _ (x * y)).
+    - intros x x' p y y' q.
       apply qglue.
-      by apply iscong. }
-    intros a b r.
-    revert x.
-    srapply Quotient_ind_hprop.
-    intro x.
-    apply qglue.
-    by apply iscong.
+      by apply iscong.
   Defined.
 
   Global Instance congquot_mon_unit : MonUnit CongruenceQuotient.
@@ -53,9 +42,10 @@ Section GroupCongruenceQuotient.
 
   Global Instance congquot_negate : Negate CongruenceQuotient.
   Proof.
-    srapply Quotient_functor.
-    1: apply negate.
-    intros x y p.
+    srapply Quotient_rec.
+    1: exact (class_of R o negate).
+    intros x y p; cbn.
+    symmetry.
     rewrite <- (left_identity (-x)).
     destruct (left_inverse y).
     set (-y * y * -x).
@@ -63,17 +53,15 @@ Section GroupCongruenceQuotient.
     destruct (right_inverse x).
     unfold g; clear g.
     rewrite <- simple_associativity.
+    apply qglue.
     apply iscong; try reflexivity.
     apply iscong; try reflexivity.
-    by symmetry.
+    exact p.
   Defined.
 
   Global Instance congquot_sgop_associative : Associative congquot_sgop.
   Proof.
-    intros x y.
-    srapply Quotient_ind_hprop; intro a; revert y.
-    srapply Quotient_ind_hprop; intro b; revert x.
-    srapply Quotient_ind_hprop; intro c.
+    srapply Quotient_ind3_hprop; intros x y z.
     simpl; by rewrite associativity.
   Qed.
 
@@ -150,22 +138,30 @@ Section QuotientGroup.
     - srapply Quotient_rec.
       + exact f.
       + cbn; intros x y n.
-        symmetry.
-        apply grp_moveL_M1.
-        rewrite <- grp_homo_inv.
-        rewrite <- grp_homo_op.
-        apply h; assumption.
+        apply grp_moveR_M1.
+        rhs_V nrapply (ap (.* f y) (grp_homo_inv _ _)).
+        rhs_V nrapply grp_homo_op.
+        symmetry; apply h; assumption.
     - intro x.
       refine (Quotient_ind_hprop _ _ _).
       intro y. revert x.
-
       refine (Quotient_ind_hprop _ _ _).
       intro x; simpl.
       apply grp_homo_op.
   Defined.
 
+  Definition grp_quotient_ind_hprop (P : QuotientGroup -> Type)
+    `{forall x, IsHProp (P x)}
+    (H1 : forall x, P (grp_quotient_map x))
+    : forall x, P x.
+  Proof.
+    srapply Quotient_ind_hprop.
+    exact H1.
+  Defined.
+
 End QuotientGroup.
 
+Arguments QuotientGroup G N : simpl never.
 Arguments grp_quotient_map {_ _}.
 
 Notation "G / N" := (QuotientGroup G N) : group_scope.
diff --git a/theories/Algebra/Groups/ShortExactSequence.v b/theories/Algebra/Groups/ShortExactSequence.v
index a73d33c5511..4fce01f90f7 100644
--- a/theories/Algebra/Groups/ShortExactSequence.v
+++ b/theories/Algebra/Groups/ShortExactSequence.v
@@ -31,7 +31,7 @@ Proof.
 Defined.
 
 Definition grp_iscomplex_trivial {X Y : Group} (f : X $-> Y)
-  : IsComplex (@grp_homo_const grp_trivial X) f.
+  : IsComplex (grp_trivial_rec X) f.
 Proof.
   srapply phomotopy_homotopy_hset.
   intro x; cbn.
@@ -40,7 +40,7 @@ Defined.
 
 (** A complex 0 -> A -> B of groups is purely exact if and only if the map A -> B is an embedding. *)
 Lemma iff_grp_isexact_isembedding {A B : Group} (f : A $-> B)
-  : IsExact purely (@grp_homo_const grp_trivial A) f <-> IsEmbedding f.
+  : IsExact purely (grp_trivial_rec A) f <-> IsEmbedding f.
 Proof.
   split.
   - intros ex b.
@@ -55,7 +55,7 @@ Defined.
 
 (** A complex 0 -> A -> B is purely exact if and only if the kernel of the map A -> B is trivial. *)
 Definition equiv_grp_isexact_kernel `{Univalence} {A B : Group} (f : A $-> B)
-  : IsExact purely (@grp_homo_const grp_trivial A) f
+  : IsExact purely (grp_trivial_rec A) f
       <~> (grp_kernel f = trivial_subgroup :> Subgroup _)
   := (equiv_kernel_isembedding f)^-1%equiv
        oE equiv_iff_hprop_uncurried (iff_grp_isexact_isembedding f).
diff --git a/theories/Algebra/Groups/Subgroup.v b/theories/Algebra/Groups/Subgroup.v
index a1efd7f3b1f..7bab540f3a3 100644
--- a/theories/Algebra/Groups/Subgroup.v
+++ b/theories/Algebra/Groups/Subgroup.v
@@ -165,9 +165,9 @@ Coercion subgroup_group : Subgroup >-> Group.
 Definition subgroup_incl {G : Group} (H : Subgroup G)
   : subgroup_group H $-> G.
 Proof.
-  snrapply Build_GroupHomomorphism'.
+  snrapply Build_GroupHomomorphism.
   1: exact pr1.
-  repeat split.
+  hnf; reflexivity.
 Defined.
 
 Global Instance isembedding_subgroup_incl {G : Group} (H : Subgroup G)
@@ -337,39 +337,93 @@ Proof.
   all: by intro.
 Defined.
 
-(** A subgroup is normal if being in a left coset is equivalent to being in a right coset represented by the same element. *)
+(** A normal subgroup is a subgroup closed under conjugation. *)
 Class IsNormalSubgroup {G : Group} (N : Subgroup G)
-  := isnormal : forall {x y}, in_cosetL N x y <~> in_cosetR N x y.
+  := isnormal : forall {x y}, N (x * y) -> N (y * x).
 
 Record NormalSubgroup (G : Group) := {
   normalsubgroup_subgroup : Subgroup G ;
   normalsubgroup_isnormal : IsNormalSubgroup normalsubgroup_subgroup ;
 }.
 
+Arguments Build_NormalSubgroup G N _ : rename.
+
 Coercion normalsubgroup_subgroup : NormalSubgroup >-> Subgroup.
 Global Existing Instance normalsubgroup_isnormal.
 
-(* Inverses are then respected *)
-Definition in_cosetL_inverse {G : Group} {N : NormalSubgroup G}
-  : forall x y : G, in_cosetL N (-x) (-y) <~> in_cosetL N x y.
+Definition equiv_symmetric_in_normalsubgroup {G : Group}
+  (N : NormalSubgroup G)
+  : forall x y, N (x * y) <~> N (y * x).
 Proof.
   intros x y.
-  unfold in_cosetL.
-  rewrite negate_involutive.
-  symmetry; apply isnormal.
+  rapply equiv_iff_hprop.
+  all: apply isnormal.
 Defined.
 
-Definition in_cosetR_inverse {G : Group} {N : NormalSubgroup G}
-  : forall x y : G, in_cosetR N (-x) (-y) <~> in_cosetR N x y.
+(** Our definiiton of normal subgroup implies the usual definition of invariance under conjugation. *)
+Definition isnormal_conjugate {G : Group} (N : NormalSubgroup G) {x y : G}
+  : N x -> N (y * x * -y).
 Proof.
-  intros x y.
-  refine (_ oE (in_cosetR_unit _ _)^-1).
-  refine (_ oE isnormal^-1).
-  refine (_ oE in_cosetL_unit _ _).
-  refine (_ oE isnormal).
+  intros n.
+  apply isnormal.
+  nrefine (transport N (grp_assoc _ _ _)^ _).
+  nrefine (transport (fun y => N (y * x)) (grp_inv_l _)^ _).
+  nrefine (transport N (grp_unit_l _)^ _).
+  exact n.
+Defined.
+
+(** We can show a subgroup is normal if it is invariant under conjugation. *)
+Definition Build_IsNormalSubgroup' (G : Group) (N : Subgroup G)
+  (isnormal : forall x y, N x -> N (y * x * -y))
+  : IsNormalSubgroup N.
+Proof.
+  intros x y n.
+  nrefine (transport N (grp_unit_r _) _).
+  nrefine (transport (fun z => N (_ * z)) (grp_inv_r y) _).
+  nrefine (transport N (grp_assoc _ _ _)^ _).
+  nrefine (transport (fun z => N (z * _)) (grp_assoc _ _ _) _).
+  by apply isnormal.
+Defined.
+
+(** Under funext, being a normal subgroup is a hprop. *)
+Global Instance ishprop_isnormalsubgroup `{Funext} {G : Group} (N : Subgroup G)
+  : IsHProp (IsNormalSubgroup N).
+Proof. 
+  unfold IsNormalSubgroup; exact _.
+Defined.
+
+(** Our definition of normal subgroup and the usual definition are therefore equivalent. *)
+Definition equiv_isnormal_conjugate `{Funext} {G : Group} (N : Subgroup G)
+  : IsNormalSubgroup N <~> (forall x y, N x -> N (y * x * -y)).
+Proof.
+  rapply equiv_iff_hprop.
+  - intros is_normal x y.
+    exact (isnormal_conjugate (Build_NormalSubgroup G N is_normal)).
+  - intros is_normal'.
+    by snrapply Build_IsNormalSubgroup'.
+Defined.
+
+(** Left and right cosets are equivalent in normal subgroups. *)
+Definition equiv_in_cosetL_in_cosetR_normalsubgroup {G : Group}
+  (N : NormalSubgroup G) (x y : G)
+  : in_cosetL N x y <~> in_cosetR N x y
+  := equiv_in_cosetR_symm _ _ oE equiv_symmetric_in_normalsubgroup _ _ _.
+
+(** Inverses are then respected *)
+Definition in_cosetL_inverse {G : Group} {N : NormalSubgroup G} (x y : G)
+  : in_cosetL N (-x) (-y) <~> in_cosetL N x y.
+Proof.
+  refine (_ oE equiv_in_cosetL_in_cosetR_normalsubgroup _ _ _); cbn.
   by rewrite negate_involutive.
 Defined.
 
+Definition in_cosetR_inverse {G : Group} {N : NormalSubgroup G} (x y : G)
+  : in_cosetR N (-x) (-y) <~> in_cosetR N x y.
+Proof.
+  refine (_ oE equiv_in_cosetL_in_cosetR_normalsubgroup _ _ _); cbn.
+  by rewrite grp_inv_inv.
+Defined.
+
 (** This lets us prove that left and right coset relations are congruences. *)
 Definition in_cosetL_cong {G : Group} {N : NormalSubgroup G}
   (x x' y y' : G)
@@ -378,13 +432,12 @@ Proof.
   cbn; intros p q.
   (** rewrite goal before applying subgroup_op *)
   rewrite negate_sg_op, <- simple_associativity.
-  apply symmetric_in_cosetL; cbn.
-  rewrite simple_associativity.
-  apply isnormal; cbn.
-  rewrite <- simple_associativity.
+  apply isnormal.
+  rewrite simple_associativity, <- simple_associativity.
   apply subgroup_in_op.
-  1: assumption.
-  by apply isnormal, symmetric_in_cosetL.
+  1: exact p.
+  apply isnormal.
+  exact q.
 Defined.
 
 Definition in_cosetR_cong  {G : Group} {N : NormalSubgroup G}
@@ -394,13 +447,12 @@ Proof.
   cbn; intros p q.
   (** rewrite goal before applying subgroup_op *)
   rewrite negate_sg_op, simple_associativity.
-  apply symmetric_in_cosetR; cbn.
-  rewrite <- simple_associativity.
-  apply isnormal; cbn.
-  rewrite simple_associativity.
+  apply isnormal.
+  rewrite <- simple_associativity, simple_associativity.
   apply subgroup_in_op.
-  2: assumption.
-  by apply isnormal, symmetric_in_cosetR.
+  2: exact q.
+  apply isnormal.
+  exact p.
 Defined.
 
 (** The property of being the trivial subgroup is useful. *)
@@ -453,6 +505,14 @@ Proof.
   exact (sgt_op sgt_unit p).
 Defined.
 
+Definition sgt_inv' {G : Group} {X} {g : G}
+  : subgroup_generated_type X (- g) -> subgroup_generated_type X g.
+Proof.
+  intros p.
+  rewrite <- grp_inv_inv.
+  by apply sgt_inv.
+Defined.
+
 Definition sgt_op' {G : Group} {X} {g h : G}
   : subgroup_generated_type X g
     -> subgroup_generated_type X h
@@ -477,6 +537,22 @@ Definition subgroup_generated_gen_incl {G : Group} {X : G -> Type} (g : G) (H :
   : subgroup_generated X
   := (g; tr (sgt_in H)).
 
+(** If [f : G $-> H] is a group homomorphism and [X] and [Y] are subsets of [G] and [H] such that [f] maps [X] into [Y], then [f] sends the subgroup generated by [X] into the subgroup generated by [Y]. *)
+Definition functor_subgroup_generated {G H : Group} (X : G -> Type) (Y : H -> Type)
+  (f : G $-> H) (preserves : forall g, X g -> Y (f g))
+  : forall g, subgroup_generated X g -> subgroup_generated Y (f g).
+Proof.
+  intro g.
+  apply Trunc_functor.
+  intro p.
+  induction p as [g i | | g h p1 IHp1 p2 IHp2].
+  - apply sgt_in, preserves, i.
+  - rewrite grp_homo_unit.
+    apply sgt_unit.
+  - rewrite grp_homo_op, grp_homo_inv.
+    by apply sgt_op.
+Defined.
+
 (** The product of two subgroups. *)
 Definition subgroup_product {G : Group} (H K : Subgroup G) : Subgroup G
   := subgroup_generated (fun x => ((H x) + (K x))%type).
diff --git a/theories/Algebra/Monoids/Monoid.v b/theories/Algebra/Monoids/Monoid.v
new file mode 100644
index 00000000000..13c59e27306
--- /dev/null
+++ b/theories/Algebra/Monoids/Monoid.v
@@ -0,0 +1,267 @@
+Require Import Basics.Overture Basics.Tactics Basics.Equivalences Basics.Trunc.
+Require Import Types.Sigma Types.Forall Types.Prod.
+Require Import WildCat.Core WildCat.Induced WildCat.Equiv WildCat.Universe
+  WildCat.Products.
+Require Import (notations) Classes.interfaces.canonical_names.
+Require Export (hints) Classes.interfaces.abstract_algebra.
+Require Export (hints) Classes.interfaces.canonical_names.
+Require Export Classes.interfaces.canonical_names (SgOp, sg_op, One, one,
+    MonUnit, mon_unit, LeftIdentity, left_identity, RightIdentity, right_identity,
+    Negate, negate, Associative, simple_associativity, associativity,
+    LeftInverse, left_inverse, RightInverse, right_inverse, Commutative, commutativity).
+Export canonical_names.BinOpNotations.
+Require Export Classes.interfaces.abstract_algebra (IsSemiGroup(..), sg_set, sg_ass,
+    IsMonoid(..), monoid_left_id, monoid_right_id, monoid_semigroup,
+    IsMonoidPreserving(..), monmor_unitmor, monmor_sgmor,
+    IsSemiGroupPreserving, preserves_sg_op, IsUnitPreserving, preserves_mon_unit).
+
+Local Set Polymorphic Inductive Cumulativity.
+Local Set Universe Minimization ToSet.
+
+Local Open Scope mc_mult_scope.
+
+(** * Monoids *)
+
+(** ** Definition *)
+
+Record Monoid := {
+  monoid_type :> Type;
+  monoid_sgop :: SgOp monoid_type;
+  monoid_unit :: MonUnit monoid_type;
+  monoid_ismonoid :: IsMonoid monoid_type;
+}.
+
+Arguments monoid_sgop {_}.
+Arguments monoid_unit {_}.
+Arguments monoid_ismonoid {_}.
+Global Opaque monoid_ismonoid.
+
+Definition issig_monoid : _ <~> Monoid := ltac:(issig).
+
+Section MonoidLaws.
+  Context {M : Monoid} (x y z : M).  
+  Definition mnd_assoc := associativity x y z.
+  Definition mnd_unit_l := left_identity x.
+  Definition mnd_unit_r := right_identity x.
+End MonoidLaws.
+
+(** ** Monoid homomorphisms *)
+
+Record MonoidHomomorphism (M N : Monoid) := {
+  mnd_homo_map :> monoid_type M -> monoid_type N;
+  ismonoidpreserving_mnd_homo :: IsMonoidPreserving mnd_homo_map;
+}.
+
+Arguments mnd_homo_map {M N}.
+Arguments Build_MonoidHomomorphism {M N} _ _.
+Arguments ismonoidpreserving_mnd_homo {M N} f : rename.
+
+Definition issig_MonoidHomomorphism (M N : Monoid)
+  : _ <~> MonoidHomomorphism M N
+  := ltac:(issig).
+
+(** ** Basics properties of monoid homomorphisms *)
+
+Definition mnd_homo_op {M N : Monoid} (f : MonoidHomomorphism M N)
+  : forall (x y : M), f (x * y) = f x * f y
+  := monmor_sgmor. 
+
+Definition mnd_homo_unit {M N : Monoid} (f : MonoidHomomorphism M N)
+  : f mon_unit = mon_unit
+  := monmor_unitmor.
+
+Definition equiv_path_monoidhomomorphism `{Funext} {M N : Monoid}
+  {f g : MonoidHomomorphism M N}
+  : f == g <~> f = g.
+Proof.
+  refine ((equiv_ap (issig_MonoidHomomorphism M N)^-1 _ _)^-1 oE _).
+  refine (equiv_path_sigma_hprop _ _ oE _).
+  apply equiv_path_forall.
+Defined.
+
+Global Instance ishset_monoidhomomorphism `{Funext} {M N : Monoid}
+  : IsHSet (MonoidHomomorphism M N).
+Proof.
+  apply istrunc_S.
+  intros f g; apply (istrunc_equiv_istrunc _ equiv_path_monoidhomomorphism).
+Defined.
+
+Definition mnd_homo_id {M : Monoid} : MonoidHomomorphism M M
+  := Build_MonoidHomomorphism idmap _.
+
+Definition mnd_homo_compose {M N P : Monoid}
+  : MonoidHomomorphism N P -> MonoidHomomorphism M N
+  -> MonoidHomomorphism M P
+  := fun f g => Build_MonoidHomomorphism (f o g) _.
+
+(** ** Monoid Isomorphisms *)
+
+Record MonoidIsomorphism (M N : Monoid) := {
+  mnd_iso_homo :> MonoidHomomorphism M N;
+  isequiv_mnd_iso :: IsEquiv mnd_iso_homo;
+}.
+
+Definition Build_MonoidIsomorphism' {M N : Monoid}
+  (f : M <~> N) (h : IsMonoidPreserving f)
+  : MonoidHomomorphism M N.
+Proof.
+  snrapply Build_MonoidIsomorphism.
+  1: srapply Build_MonoidHomomorphism.
+  exact _.
+Defined.
+
+Definition issig_MonoidIsomorphism (M N : Monoid)
+  : _ <~> MonoidIsomorphism M N
+  := ltac:(issig).
+
+Coercion equiv_mnd_iso {M N : Monoid}
+  : MonoidIsomorphism M N -> M <~> N
+  := fun f => Build_Equiv M N f _. 
+
+Definition mnd_iso_id {M : Monoid} : MonoidIsomorphism M M
+  := Build_MonoidIsomorphism _ _ mnd_homo_id _.
+
+Definition mnd_iso_compose {M N P : Monoid}
+  : MonoidIsomorphism N P -> MonoidIsomorphism M N
+  -> MonoidIsomorphism M P
+  := fun g f => Build_MonoidIsomorphism _ _ (mnd_homo_compose g f) _.
+
+Definition mnd_iso_inverse {M N : Monoid}
+  : MonoidIsomorphism M N -> MonoidIsomorphism N M
+  := fun f => Build_MonoidIsomorphism _ _ (Build_MonoidHomomorphism f^-1 _) _.
+
+Global Instance reflexive_monoidisomorphism
+  : Reflexive MonoidIsomorphism
+  := fun M => mnd_iso_id.
+
+Global Instance symmetric_monoidisomorphism
+  : Symmetric MonoidIsomorphism
+  := fun M N => mnd_iso_inverse.
+
+Global Instance transitive_monoidisomorphism
+  : Transitive MonoidIsomorphism
+  := fun M N P f g => mnd_iso_compose g f.
+
+(** ** The category of monoids *)
+
+Global Instance isgraph_monoid : IsGraph Monoid
+  := Build_IsGraph Monoid MonoidHomomorphism.
+
+Global Instance is01cat_monoid : Is01Cat Monoid
+  := Build_Is01Cat Monoid _ (@mnd_homo_id) (@mnd_homo_compose).
+
+Local Notation mnd_homo_map' M N
+  := (@mnd_homo_map M N : _ -> (monoid_type M $-> _)).
+
+Global Instance is2graph_monoid : Is2Graph Monoid
+  := fun M N => isgraph_induced (mnd_homo_map' M N).
+
+Global Instance isgraph_monoidhomomorphism {M N : Monoid} : IsGraph (M $-> N)
+  := isgraph_induced (mnd_homo_map' M N).
+
+Global Instance is01cat_monoidhomomorphism {M N : Monoid} : Is01Cat (M $-> N)
+  := is01cat_induced (mnd_homo_map' M N).
+
+Global Instance is0gpd_monoidhomomorphism {M N : Monoid} : Is0Gpd (M $-> N)
+  := is0gpd_induced (mnd_homo_map' M N).
+
+Global Instance is0functor_postcomp_monoidhomomorphism
+  {M N P : Monoid} (h : N $-> P)
+  : Is0Functor (@cat_postcomp Monoid _ _ M N P h).
+Proof.
+  apply Build_Is0Functor.
+  intros ? ? p a; exact (ap h (p a)).
+Defined.
+
+Global Instance is0functor_precomp_monoidhomomorphism
+  {M N P : Monoid} (h : M $-> N)
+  : Is0Functor (@cat_precomp Monoid _ _ M N P h).
+Proof.
+  apply Build_Is0Functor.
+  intros ? ? p; exact (p o h).
+Defined.
+
+Global Instance is1cat_monoid : Is1Cat Monoid.
+Proof.
+  by rapply Build_Is1Cat.
+Defined.
+
+Global Instance hasequivs_monoid : HasEquivs Monoid.
+Proof.
+  snrapply Build_HasEquivs.
+  - exact MonoidIsomorphism.
+  - exact (fun M N f => IsEquiv f).
+  - intros M N f; exact f.
+  - cbn; exact _.
+  - exact Build_MonoidIsomorphism.
+  - reflexivity.
+  - intros M N; exact mnd_iso_inverse.
+  - intros ????; apply eissect.
+  - intros ????; apply eisretr.
+  - intros M N; exact isequiv_adjointify.
+Defined.
+
+Global Instance is0functor_monoid_type : Is0Functor monoid_type
+  := Build_Is0Functor _ _ _ _ monoid_type (@mnd_homo_map).
+
+Global Instance is1functor_monoid_type : Is1Functor monoid_type.
+Proof.
+  by apply Build_Is1Functor.
+Defined.
+
+(** ** Direct product of monoids *)
+
+Definition mnd_prod : Monoid -> Monoid -> Monoid.
+Proof.
+  intros M N.
+  snrapply (Build_Monoid (M * N)).
+  3: repeat split.
+  - intros [m1 n1] [m2 n2].
+    exact (m1 * m2, n1 * n2).
+  - exact (mon_unit, mon_unit).
+  - exact _.
+  - intros x y z; snrapply path_prod; nrapply mnd_assoc.
+  - intros x; snrapply path_prod; nrapply mnd_unit_l.
+  - intros x; snrapply path_prod; nrapply mnd_unit_r.
+Defined.
+
+Definition mnd_prod_pr1 {M N : Monoid}
+  : MonoidHomomorphism (mnd_prod M N) M.
+Proof.
+  snrapply Build_MonoidHomomorphism.
+  1: exact fst.
+  split; hnf; reflexivity.
+Defined.
+
+Definition mnd_prod_pr2 {M N : Monoid}
+  : MonoidHomomorphism (mnd_prod M N) N.
+Proof.
+  snrapply Build_MonoidHomomorphism.
+  1: exact snd.
+  split; hnf; reflexivity.
+Defined.
+
+Definition mnd_prod_corec {M N P : Monoid}
+  (f : MonoidHomomorphism P M)
+  (g : MonoidHomomorphism P N)
+  : MonoidHomomorphism P (mnd_prod M N).
+Proof.
+  snrapply Build_MonoidHomomorphism.
+  2: split.
+  - exact (fun x => (f x, g x)).
+  - intros x y; snrapply path_prod; nrapply mnd_homo_op.
+  - snrapply path_prod; nrapply mnd_homo_unit.
+Defined.
+
+Global Instance hasbinaryproducts_monoid : HasBinaryProducts Monoid.
+Proof.
+  intros M N.
+  snrapply Build_BinaryProduct.
+  - exact (mnd_prod M N).
+  - exact mnd_prod_pr1.
+  - exact mnd_prod_pr2.
+  - intros P; exact mnd_prod_corec.
+  - intros P f g; exact (Id _).
+  - intros P f g; exact (Id _).
+  - intros P f g p q a; exact (path_prod' (p a) (q a)).
+Defined.
diff --git a/theories/Algebra/Rings.v b/theories/Algebra/Rings.v
index 3b0579c95fb..872603ad13b 100644
--- a/theories/Algebra/Rings.v
+++ b/theories/Algebra/Rings.v
@@ -1,5 +1,6 @@
 (** Basic theory *)
 
+Require Export HoTT.Algebra.Rings.Ring.
 Require Export HoTT.Algebra.Rings.CRing.
 Require Export HoTT.Algebra.Rings.Ideal.
 Require Export HoTT.Algebra.Rings.QuotientRing.
diff --git a/theories/Algebra/Rings/CRing.v b/theories/Algebra/Rings/CRing.v
index da3565f66ee..1259284c0fb 100644
--- a/theories/Algebra/Rings/CRing.v
+++ b/theories/Algebra/Rings/CRing.v
@@ -1,434 +1,281 @@
 Require Import WildCat.
-Require Import Spaces.Nat.Core.
 (* Some of the material in abstract_algebra and canonical names could be selectively exported to the user, as is done in Groups/Group.v. *)
 Require Import Classes.interfaces.abstract_algebra.
 Require Import Algebra.AbGroups.
-Require Export Classes.theory.rings.
-Require Import Modalities.ReflectiveSubuniverse.
+Require Export Algebra.Rings.Ring Algebra.Rings.Ideal Algebra.Rings.QuotientRing.
 
-(** Theory of commutative rings *)
-
-(** TODO: We should really develop the theory of non-commutative rings seperately, and have commutative rings as a special case of that theory. Similar to how we have Group and AbGroup. But since we are only interested in commutative rings for the time being, it makes sense to only consider them. *)
-
-Declare Scope ring_scope.
+(** * Commutative Rings *)
 
 Local Open Scope ring_scope.
-(** We want to print equivalences as [≅]. *)
 Local Open Scope wc_iso_scope.
 
-(** A commutative ring consists of the following data *)
+(** A commutative ring consists of the following data: *)
 Record CRing := {
-  cring_type : Type;
-  cring_plus : Plus cring_type;
-  cring_mult : Mult cring_type;
-  cring_zero : Zero cring_type;
-  cring_one  : One  cring_type;
-  cring_negate : Negate cring_type;
-  cring_isring : IsRing cring_type;
+  (** An underlying ring. *)
+  cring_ring :> Ring;
+  (** Such that they satisfy the axioms of a commutative ring. *)
+  cring_commutative :: Commutative (A:=cring_ring) (.*.);
 }.
 
-Arguments cring_plus {_}.
-Arguments cring_mult {_}.
-Arguments cring_zero {_}.
-Arguments cring_one {_}.
-Arguments cring_negate {_}.
-Arguments cring_isring {_}.
-
 Definition issig_CRing : _ <~> CRing := ltac:(issig).
 
-(** We coerce rings to their underlying type. *)
-Coercion cring_type : CRing >-> Sortclass.
-(** All fields which are typeclasses are global instances *)
-Global Existing Instances cring_plus cring_mult cring_zero cring_one cring_negate cring_isring.
-
-(** A ring homomorphism between commutative rings is a map of the underlying type and a proof that this map is a ring homomorphism. *)
-Record CRingHomomorphism (A B : CRing) := {
-  rng_homo_map : A -> B;
-  rng_homo_ishomo : IsSemiRingPreserving rng_homo_map;
-}.
-
-Arguments Build_CRingHomomorphism {_ _} _ _.
-
-Definition issig_CRingHomomorphism (A B : CRing)
-  : _ <~> CRingHomomorphism A B
-  := ltac:(issig).
+Global Instance cring_plus {R : CRing} : Plus R := plus_abgroup R.
+Global Instance cring_zero {R : CRing} : Zero R := zero_abgroup R.
+Global Instance cring_negate {R : CRing} : Negate R := negate_abgroup R.
 
-(** We coerce ring homomorphisms to their underlying maps *)
-Coercion rng_homo_map : CRingHomomorphism >-> Funclass.
-Global Existing Instance rng_homo_ishomo.
-
-Definition equiv_path_cringhomomorphism `{Funext} {A B : CRing}
-  {f g : CRingHomomorphism A B} : f == g <~> f = g.
-Proof.
-  refine ((equiv_ap (issig_CRingHomomorphism A B)^-1 _ _)^-1 oE _).
-  refine (equiv_path_sigma_hprop _ _ oE _).
-  apply equiv_path_forall.
-Defined.
-
-Definition rng_homo_id (A : CRing) : CRingHomomorphism A A
-  := Build_CRingHomomorphism idmap _.
-
-Definition rng_homo_compose {A B C : CRing}
-  (f : CRingHomomorphism B C) (g : CRingHomomorphism A B)
-  : CRingHomomorphism A C.
+Definition Build_CRing' (R : AbGroup) `(!One R, !Mult R)
+  (comm : Commutative (.*.)) (assoc : Associative (.*.))
+  (dist_l : LeftDistribute (.*.) (+)) (unit_l : LeftIdentity (.*.) 1)
+  : CRing.
 Proof.
-  snrapply Build_CRingHomomorphism.
-  1: exact (f o g).
-  rapply compose_sr_morphism.
-Defined.
-
-(** ** Ring laws *)
-
-Section RingLaws.
-
-  (** Many of these ring laws have already been proven. But we give them names here so that they are easy to find and use. *)
-
-  Context {A B : CRing} (f : CRingHomomorphism A B) (x y z : A).
-
-  Definition rng_dist_l : x * (y + z) = x * y + x * z := simple_distribute_l _ _ _.
-  Definition rng_dist_r : (x + y) * z = x * z + y * z := simple_distribute_r _ _ _.
-  Definition rng_plus_zero_l : 0 + x = x := left_identity _.
-  Definition rng_plus_zero_r : x + 0 = x := right_identity _.
-  Definition rng_plus_negate_l : (- x) + x = 0 := left_inverse _.
-  Definition rng_plus_negate_r : x + (- x) = 0 := right_inverse _.
-
-  Definition rng_plus_comm : x + y = y + x := commutativity x y.
-  Definition rng_plus_assoc : x + (y + z) = (x + y) + z := simple_associativity x y z.
-  Definition rng_mult_comm : x * y = y * x := commutativity x y.
-  Definition rng_mult_assoc : x * (y * z) = (x * y) * z := simple_associativity x y z.
-
-  Definition rng_negate_negate : - (- x) = x := negate_involutive _.
-
-  Definition rng_mult_one_l : 1 * x = x := left_identity _.
-  Definition rng_mult_one_r : x * 1 = x := right_identity _.
-  Definition rng_mult_zero_l : 0 * x = 0 := left_absorb _.
-  Definition rng_mult_zero_r : x * 0 = 0 := right_absorb _.
-  Definition rng_mult_negate : -1 * x = - x := (negate_mult _)^.
-  Definition rng_mult_negate_negate : -x * -y = x * y := negate_mult_negate _ _.
-  Definition rng_mult_negate_l : -x * y = -(x * y) := inverse (negate_mult_distr_l _ _).
-  Definition rng_mult_negate_r : x * -y = -(x * y) := inverse (negate_mult_distr_r _ _).
-
-  Definition rng_homo_plus : f (x + y) = f x + f y := preserves_plus x y.
-  Definition rng_homo_mult : f (x * y) = f x * f y := preserves_mult x y.
-  Definition rng_homo_zero : f 0 = 0 := preserves_0.
-  Definition rng_homo_one  : f 1 = 1 := preserves_1.
-  Definition rng_homo_negate : f (-x) = -(f x) := preserves_negate x.
-
-  Definition rng_homo_minus_one : f (-1) = -1
-    := preserves_negate 1%mc @ ap negate preserves_1.
-
-End RingLaws.
-
-(** Isomorphisms of commutative rings *)
-Record CRingIsomorphism (A B : CRing) := {
-  rng_iso_homo : CRingHomomorphism A B ;
-  isequiv_rng_iso_homo : IsEquiv rng_iso_homo ;
-}.
-
-Arguments rng_iso_homo {_ _ }.
-Coercion rng_iso_homo : CRingIsomorphism >-> CRingHomomorphism.
-Global Existing Instance isequiv_rng_iso_homo.
-
-Definition issig_CRingIsomorphism {A B : CRing}
-  : _ <~> CRingIsomorphism A B := ltac:(issig).
-
-(** We can construct a ring isomorphism from an equivalence that preserves addition and multiplication. *)
-Definition Build_CRingIsomorphism' (A B : CRing) (e : A <~> B)
-  `{!IsSemiRingPreserving e}
-  : CRingIsomorphism A B
-  := Build_CRingIsomorphism A B (Build_CRingHomomorphism e _) _.
-
-(** The inverse of a CRing isomorphism *)
-Definition rng_iso_inverse {A B : CRing}
-  : CRingIsomorphism A B -> CRingIsomorphism B A.
-Proof.
-  intros [f e].
-  snrapply Build_CRingIsomorphism.
-  { snrapply Build_CRingHomomorphism.
-    1: exact f^-1.
-    exact _. }
-  exact _.
-Defined.
-
-(** CRing isomorphisms are a reflexive relation *)
-Global Instance reflexive_cringisomorphism : Reflexive CRingIsomorphism
-  := fun x => Build_CRingIsomorphism _ _ (rng_homo_id x) _.
-
-(** CRing isomorphisms are a symmetric relation *)
-Global Instance symmetry_cringisomorphism : Symmetric CRingIsomorphism
-  := fun x y => rng_iso_inverse.
-
-(** CRing isomorphisms are a transitive relation *)
-Global Instance transitive_cringisomorphism : Transitive CRingIsomorphism
-  := fun x y z f g => Build_CRingIsomorphism _ _ (rng_homo_compose g f) _.
-
-(** Underlying abelian groups of rings *)
-Definition abgroup_cring : CRing -> AbGroup.
-Proof.
-  intro A.
-  snrapply Build_AbGroup.
-  - srapply (Build_Group (cring_type A)).
+  snrapply Build_CRing.
+  - rapply (Build_Ring R); only 1: exact _.
+    2: repeat split; only 1-3: exact _.
+    + intros x y z.
+      lhs nrapply comm.
+      lhs rapply dist_l.
+      f_ap.
+    + intros x.
+      lhs rapply comm.
+      apply unit_l.
   - exact _.
 Defined.
 
-Coercion abgroup_cring : CRing >-> AbGroup.
-
-(** Underlying group homomorphism of a ring homomorphism *)
-Definition grp_homo_rng_homo {R S : CRing}
-  : CRingHomomorphism R S -> GroupHomomorphism R S
-  := fun f => @Build_GroupHomomorphism R S f _.
-
-Coercion grp_homo_rng_homo : CRingHomomorphism >-> GroupHomomorphism.
-
-(** We can construct a ring homomorphism from a group homomorphism that preserves multiplication *)
-Definition Build_CRingHomomorphism' (A B : CRing) (map : GroupHomomorphism A B)
-  {H : IsMonoidPreserving (Aop:=cring_mult) (Bop:=cring_mult)
-    (Aunit:=one) (Bunit:=one) map}
-  : CRingHomomorphism A B
-  := Build_CRingHomomorphism map
-      (Build_IsSemiRingPreserving _ (grp_homo_ishomo _ _ map) H).
-
-(** We can construct a ring isomorphism from a group isomorphism that preserves multiplication *)
-Definition Build_CRingIsomorphism'' (A B : CRing) (e : GroupIsomorphism A B)
-  {H : IsMonoidPreserving (Aop:=cring_mult) (Bop:=cring_mult) (Aunit:=one) (Bunit:=one) e}
-  : CRingIsomorphism A B
-  := @Build_CRingIsomorphism' A B e (Build_IsSemiRingPreserving e _ H).
-
-(** Here is an alternative way to build a commutative ring using the underlying abelian group. *)
-Definition Build_CRing' (R : AbGroup)
-  `(Mult R, One R, LeftDistribute R mult (@group_sgop R))
-  (iscomm : @IsCommutativeMonoid R mult one)
-  : CRing
-  := Build_CRing R (@group_sgop R) _ (@group_unit R) _
-       (@group_inverse R) (Build_IsRing _ _ _ _).
-
-(** ** Ring movement lemmas *)
-
-Section RingMovement.
-
-  (** We adopt a similar naming convention to the [moveR_equiv] style lemmas that can be found in Types.Paths. *)
-
-  Context {R : CRing} {x y z : R}.
-
-  Definition rng_moveL_Mr : - y + x = z <~> x = y + z := @grp_moveL_Mg R x y z.
-  Definition rng_moveL_rM : x + - z = y <~> x = y + z := @grp_moveL_gM R x y z.
-  Definition rng_moveR_Mr : y = - x + z <~> x + y = z := @grp_moveR_Mg R x y z.
-  Definition rng_moveR_rM : x = z + - y <~> x + y = z := @grp_moveR_gM R x y z.
-
-  Definition rng_moveL_Vr : x + y = z <~> y = - x + z := @grp_moveL_Vg R x y z.
-  Definition rng_moveL_rV : x + y = z <~> x = z + - y := @grp_moveL_gV R x y z.
-  Definition rng_moveR_Vr : x = y + z <~> - y + x = z := @grp_moveR_Vg R x y z.
-  Definition rng_moveR_rV : x = y + z <~> x + - z = y := @grp_moveR_gV R x y z.
-
-  Definition rng_moveL_M0 : - y + x = 0 <~> x = y := @grp_moveL_M1 R x y.
-  Definition rng_moveL_0M :	x + - y = 0 <~> x = y := @grp_moveL_1M R x y.
-  Definition rng_moveR_M0 : 0 = - x + y <~> x = y := @grp_moveR_M1 R x y.
-  Definition rng_moveR_0M : 0 = y + - x <~> x = y := @grp_moveR_1M R x y.
-
-  (** TODO: Movement laws about mult *)
-
-End RingMovement.
-
-(** ** Wild category of commutative rings *)
-
-Global Instance isgraph_cring : IsGraph CRing
-  := Build_IsGraph _ CRingHomomorphism.
-
-Global Instance is01cat_cring : Is01Cat CRing
-  := Build_Is01Cat _ _ rng_homo_id (@rng_homo_compose).
-
-Global Instance is2graph_cring : Is2Graph CRing
-  := fun A B => isgraph_induced (@rng_homo_map A B).
-
-Global Instance is01cat_cringhomomorphism {A B : CRing} : Is01Cat (A $-> B)
-  := is01cat_induced (@rng_homo_map A B).
-
-Global Instance is0gpd_cringhomomorphism {A B : CRing} : Is0Gpd (A $-> B)
-  := is0gpd_induced (@rng_homo_map A B).
-
-Global Instance is0functor_postcomp_cringhomomorphism {A B C : CRing} (h : B $-> C)
-  : Is0Functor (@cat_postcomp CRing _ _ A B C h).
-Proof.
-  apply Build_Is0Functor.
-  intros [f ?] [g ?] p a ; exact (ap h (p a)).
-Defined.
-
-Global Instance is0functor_precomp_cringhomomorphism
-       {A B C : CRing} (h : A $-> B)
-  : Is0Functor (@cat_precomp CRing _ _ A B C h).
-Proof.
-  apply Build_Is0Functor.
-  intros [f ?] [g ?] p a ; exact (p (h a)).
-Defined.
-
-(** CRing forms a 1Cat *)
-Global Instance is1cat_cring : Is1Cat CRing.
-Proof.
-  by rapply Build_Is1Cat.
-Defined.
-
-Global Instance hasmorext_cring `{Funext} : HasMorExt CRing.
-Proof.
-  srapply Build_HasMorExt.
-  intros A B f g; cbn in *.
-  snrapply @isequiv_homotopic.
-  1: exact (equiv_path_cringhomomorphism^-1%equiv).
-  1: exact _.
-  intros []; reflexivity. 
-Defined.
-
-Global Instance hasequivs_cring : HasEquivs CRing.
-Proof.
-  unshelve econstructor.
-  + exact CRingIsomorphism.
-  + exact (fun G H f => IsEquiv f).
-  + intros G H f; exact f.
-  + exact Build_CRingIsomorphism.
-  + intros G H; exact rng_iso_inverse.
-  + cbn; exact _.
-  + reflexivity.
-  + intros ????; apply eissect.
-  + intros ????; apply eisretr.
-  + intros G H f g p q.
-    exact (isequiv_adjointify f g p q).
-Defined.
+(** ** Properties of commutative rings *)
 
-(** ** Product ring *)
+Definition rng_mult_comm {R : CRing} (x y : R) : x * y = y * x := commutativity x y.
 
-Definition cring_product : CRing -> CRing -> CRing.
+(** Powers commute with multiplication *)
+Lemma rng_power_mult {R : CRing} (x y : R) (n : nat)
+  : rng_power (R:=R) (x * y) n = rng_power (R:=R) x n * rng_power (R:=R) y n.
 Proof.
-  intros R S.
-  snrapply Build_CRing'.
-  1: exact (ab_biprod R S).
-  1: exact (fun '(r1 , s1) '(r2 , s2) => (r1 * r2 , s1 * s2)).
-  1: exact (cring_one , cring_one).
-  { intros [r1 s1] [r2 s2] [r3 s3].
-    apply path_prod; cbn; apply rng_dist_l. }
-  repeat split.
-  1: exact _.
-  { intros [r1 s1] [r2 s2] [r3 s3].
-    apply path_prod; cbn; apply rng_mult_assoc. }
-  1: intros [r1 s1]; apply path_prod; cbn; apply rng_mult_one_l.
-  1: intros [r1 s1]; apply path_prod; cbn; apply rng_mult_one_r.
-  intros [r1 s1] [r2 s2]; apply path_prod; cbn; apply rng_mult_comm.
+  induction n.
+  1: symmetry; rapply rng_mult_one_l.
+  simpl.
+  rewrite (rng_mult_assoc (A:=R)).
+  rewrite <- (rng_mult_assoc (A:=R) x _ y).
+  rewrite (rng_mult_comm (rng_power (R:=R) x n) y).
+  rewrite rng_mult_assoc.
+  rewrite <- (rng_mult_assoc _ (rng_power (R:=R) x n)).
+  f_ap.
 Defined.
 
-Infix "×" := cring_product : ring_scope.
-
-Definition cring_product_fst {R S : CRing} : R × S $-> R.
+Definition rng_mult_permute_2_3 {R : CRing} (x y z : R)
+  : x * y * z = x * z * y.
 Proof.
-  snrapply Build_CRingHomomorphism.
-  1: exact fst.
-  repeat split.
+  lhs_V nrapply rng_mult_assoc.
+  rhs_V nrapply rng_mult_assoc.
+  apply ap, rng_mult_comm.
 Defined.
 
-Definition cring_product_snd {R S : CRing} : R × S $-> S.
+Definition rng_mult_move_left_assoc {R : CRing} (x y z : R)
+  : x * y * z = y * x * z.
 Proof.
-  snrapply Build_CRingHomomorphism.
-  1: exact snd.
-  repeat split.
+  f_ap; apply rng_mult_comm.
 Defined.
 
-Definition cring_product_corec (R S T : CRing)
-  : (R $-> S) -> (R $-> T) -> (R $-> S × T).
+Definition rng_mult_move_right_assoc {R : CRing} (x y z : R)
+  : x * (y * z) = y * (x * z).
 Proof.
-  intros f g.
-  srapply Build_CRingHomomorphism'.
-  1: apply (ab_biprod_corec f g).
-  repeat split.
-  1: cbn; intros x y; apply path_prod; apply rng_homo_mult.
-  cbn; apply path_prod; apply rng_homo_one.
+  refine (rng_mult_assoc _ _ _ @ _ @ (rng_mult_assoc _ _ _)^).
+  apply rng_mult_move_left_assoc.
 Defined.
 
-Definition equiv_cring_product_corec `{Funext} (R S T : CRing)
-  : (R $-> S) * (R $-> T) <~> (R $-> S × T).
+Definition isinvertible_cring (R : CRing) (x : R)
+  (inv : R) (inv_l : inv * x = 1)
+  : IsInvertible R x.
 Proof.
-  snrapply equiv_adjointify.
-  1: exact (uncurry (cring_product_corec _ _ _)).
-  { intros f.
-    exact (cring_product_fst $o f , cring_product_snd $o f). }
-  { hnf; intros f.
-    by apply path_hom. }
-  intros [f g].
-  apply path_prod.
-  1,2: by apply path_hom.
+  snrapply Build_IsInvertible.
+  - exact inv.
+  - exact inv_l.
+  - lhs nrapply rng_mult_comm.
+    exact inv_l.
 Defined.
 
-(** ** Image ring *)
-
-(** The image of a ring homomorphism *)
-Definition rng_image {R S : CRing} (f : R $-> S) : CRing.
-Proof.
-  snrapply (Build_CRing' (abgroup_image f)).
-  { simpl.
-    intros [x p] [y q].
-    exists (x * y).
-    strip_truncations; apply tr.
-    destruct p as [p p'], q as [q q'].
-    exists (p * q).
-    refine (rng_homo_mult _ _ _ @ _).
-    f_ap. }
-  { exists 1.
+(** ** Ideals in commutative rings *)
+  
+Section IdealCRing.
+  Context {R : CRing}.
+  
+  (** The section is meant to complement the IdealLemmas section in Algebra.Rings.Ideal. Since the results here only hold in commutative rings, they have to be kept here. *)
+  
+  (** We import ideal notations as used in Algebra.Rings.Ideal but only for this section. Important to note is that [↔] corresponds to equality of ideals. *)
+  Import Ideal.Notation.
+  Local Open Scope ideal_scope.
+
+  (** In a commutative ring, the product of two ideals is a subset of the reversed product. *)
+  Lemma ideal_product_subset_product_commutative (I J : Ideal R)
+    : I ⋅ J ⊆ J ⋅ I.
+  Proof.
+    intros r p.
+    strip_truncations.
+    induction p as [r p | |].
+    2: apply ideal_in_zero.
+    2: by apply ideal_in_plus_negate.
+    destruct p as [s t p q].
+    rewrite rng_mult_comm.
     apply tr.
-    exists 1.
-    exact (rng_homo_one f). }
-  (** Much of this proof is doing the same thing over, so we use some compact tactics. *)
-  2: repeat split.
-  2: exact _.
-  all: intros [].
-  1,2,5: intros [].
-  1,2: intros [].
-  all: apply path_sigma_hprop; cbn.
-  1: apply distribute_l.
-  1: apply associativity.
-  1: apply commutativity.
-  1: apply left_identity.
-  apply right_identity.
-Defined.
-
-Lemma rng_homo_image_incl {R S} (f : CRingHomomorphism R S)
-  : rng_image f $-> S.
+    apply sgt_in.
+    by rapply ipn_in.
+  Defined.
+
+  (** Ideal products are commutative in commutative rings. Note that we are using ideal notations here and [↔] corresponds to equality of ideals. Essentially a subset in each direction. *)
+  Lemma ideal_product_comm (I J : Ideal R) : I ⋅ J ↔ J ⋅ I.
+  Proof.
+    apply ideal_subset_antisymm;
+    apply ideal_product_subset_product_commutative.
+  Defined.
+  
+  (** Product of intersection and sum is a subset of product. Note that this is a generalization of lcm * gcd = product *)
+  Lemma ideal_product_intersection_sum_subset' (I J : Ideal R)
+    : (I ∩ J) ⋅ (I + J) ⊆ I ⋅ J.
+  Proof.
+    etransitivity.
+    2: rapply ideal_sum_self.
+    etransitivity.
+    2: rapply ideal_sum_subset_pres_r.
+    2: rapply ideal_product_comm.
+    apply ideal_product_intersection_sum_subset.
+  Defined.
+ 
+  (** If the sum of ideals is the whole ring then their intersection is a subset of their product. *)
+  Lemma ideal_intersection_subset_product (I J : Ideal R)
+    : ideal_unit R ⊆ (I + J) -> I ∩ J ⊆ I ⋅ J.
+  Proof.
+    intros p.
+    etransitivity.
+    { apply ideal_eq_subset.
+      symmetry.
+      apply ideal_product_unit_r. }
+    etransitivity.
+    1: rapply (ideal_product_subset_pres_r _ _ _ p).
+    rapply ideal_product_intersection_sum_subset'.
+  Defined.
+
+  (** This can be combined into a sufficient (but not necessary) condition for equality of intersections and products. *)
+  Lemma ideal_intersection_is_product (I J : Ideal R)
+    : Coprime I J -> I ∩ J ↔ I ⋅ J.
+  Proof.
+    intros p.
+    apply ideal_subset_antisymm.
+    - apply ideal_intersection_subset_product.
+      unfold Coprime in p.
+      apply symmetry in p.
+      rapply p.
+    - apply ideal_product_subset_intersection.
+  Defined.
+
+  Lemma ideal_quotient_product (I J K : Ideal R)
+    : (I :: J) :: K ↔ (I :: (J ⋅ K)).
+  Proof.
+    apply ideal_subset_antisymm.
+    - intros x [p q]; strip_truncations; split; apply tr;
+      intros r; rapply Trunc_rec; intros jk.
+      + induction jk as [y [z z' j k] | | ? ? ? ? ? ? ].
+        * rewrite (rng_mult_comm z z').
+          rewrite rng_mult_assoc.
+          destruct (p z' k) as [p' ?].
+          revert p'; apply Trunc_rec; intros p'.
+          exact (p' z j).
+        * change (I (x * 0)).
+          rewrite rng_mult_zero_r.
+          apply ideal_in_zero.
+        * change (I (x * (g - h))).
+          rewrite rng_dist_l.
+          rewrite rng_mult_negate_r.
+          by apply ideal_in_plus_negate.
+      + induction jk as [y [z z' j k] | | ? ? ? ? ? ? ].
+        * change (I (z * z' * x)).
+          rewrite <- rng_mult_assoc.
+          rewrite (rng_mult_comm z).
+          destruct (q z' k) as [q' ?].
+          revert q'; apply Trunc_rec; intros q'.
+          exact (q' z j).
+        * change (I (0 * x)).
+          rewrite rng_mult_zero_l.
+          apply ideal_in_zero.
+        * change (I ((g - h) * x)).
+          rewrite rng_dist_r.
+          rewrite rng_mult_negate_l.
+          by apply ideal_in_plus_negate.
+    - intros x [p q]; strip_truncations; split; apply tr;
+      intros r k; split; apply tr; intros z j.
+      + rewrite <- rng_mult_assoc.
+        rewrite (rng_mult_comm r z).
+        by apply p, tr, sgt_in, ipn_in.
+      + cbn in z.
+        change (I (z * (x * r))).
+        rewrite (rng_mult_comm x).
+        rewrite rng_mult_assoc.
+        by apply q, tr, sgt_in, ipn_in.
+      + cbn in r.
+        change (I (r * x * z)).
+        rewrite <- rng_mult_assoc.
+        rewrite (rng_mult_comm r).
+        rewrite <- rng_mult_assoc.
+        by apply p, tr, sgt_in, ipn_in.
+      + cbn in r, z.
+        change (I (z * (r * x))).
+        rewrite rng_mult_assoc.
+        rewrite rng_mult_comm.
+        by apply p, tr, sgt_in, ipn_in.
+  Defined.
+  
+  (** The ideal quotient is a right adjoint to the product in the monoidal lattice of ideals. *)
+  Lemma ideal_quotient_subset_prod (I J K : Ideal R)
+    : I ⋅ J ⊆ K <-> I ⊆ (K :: J).
+  Proof.
+    split.
+    - intros p r i; split; apply tr; intros s j; cbn in s, r.
+      + by apply p, tr, sgt_in, ipn_in.
+      + change (K (s * r)).
+        rewrite (rng_mult_comm s r).
+        by apply p, tr, sgt_in; rapply ipn_in.
+    - intros p x.
+      apply Trunc_rec.
+      intros q.
+      induction q as [r x | | ].
+      { destruct x.
+        specialize (p x s); destruct p as [p q].
+        revert p; apply Trunc_rec; intros p.
+        by apply p. }
+      1: apply ideal_in_zero.
+      by apply ideal_in_plus_negate.
+  Defined.
+
+  (** Ideal quotients partially cancel *)
+  Lemma ideal_quotient_product_left (I J : Ideal R)
+    : (I :: J) ⋅ J ⊆ I.
+  Proof.
+    by apply ideal_quotient_subset_prod.
+  Defined.
+
+End IdealCRing.
+
+(** ** Category of commutative rings. *)
+
+Global Instance isgraph_CRing : IsGraph CRing := isgraph_induced cring_ring.
+Global Instance is01cat_CRing : Is01Cat CRing := is01cat_induced cring_ring.
+Global Instance is2graph_CRing : Is2Graph CRing := is2graph_induced cring_ring.
+Global Instance is1cat_CRing : Is1Cat CRing := is1cat_induced cring_ring.
+Global Instance hasequiv_CRing : HasEquivs CRing := hasequivs_induced cring_ring.
+
+(** ** Quotient rings *)
+
+Global Instance commutative_quotientring_mult (R : CRing) (I : Ideal R)
+  : Commutative (A:=QuotientRing R I) (.*.).
 Proof.
-  snrapply Build_CRingHomomorphism.
-  1: exact pr1.
-  repeat split.
+  intros x; srapply QuotientRing_ind_hprop; intros y; revert x.
+  srapply QuotientRing_ind_hprop; intros x; hnf.
+  lhs_V nrapply rng_homo_mult.
+  rhs_V nrapply rng_homo_mult.
+  snrapply ap.
+  apply commutativity.
 Defined.
 
-(** Image of a surjective ring homomorphism *)
-Lemma rng_image_issurj {R S} (f : CRingHomomorphism R S) {issurj : IsSurjection f}
-  : rng_image f ≅ S.
-Proof.
-  snrapply Build_CRingIsomorphism.
-  1: exact (rng_homo_image_incl f).
-  exact _.
-Defined. 
-
-(** *** More Ring laws *)
-
-(** Powers of ring elements *)
-Definition rng_power {R : CRing} (x : R) (n : nat) : R := nat_iter n (x *.) cring_one.
+Definition cring_quotient (R : CRing) (I : Ideal R) : CRing
+  := Build_CRing (QuotientRing R I) _.
 
-(** Power laws *)
-Lemma rng_power_mult_law {R : CRing} (x : R) (n m : nat)
-  : (rng_power x n) * (rng_power x m) = rng_power x (n + m).
-Proof.
-  induction n as [|n IHn].
-  1: apply rng_mult_one_l.
-  refine ((rng_mult_assoc _ _ _)^ @ _).
-  exact (ap (x *.) IHn).
-Defined.
-
-(** Powers commute with multiplication *)
-Lemma rng_power_mult {R : CRing} (x y : R) (n : nat)
-  : rng_power (x * y) n = rng_power x n * rng_power y n.
-Proof.
-  induction n.
-  1: symmetry; apply rng_mult_one_l.
-  simpl.
-  rewrite rng_mult_assoc.
-  rewrite <- (rng_mult_assoc x _ y).
-  rewrite (rng_mult_comm (rng_power x n) y).
-  rewrite rng_mult_assoc.
-  rewrite <- (rng_mult_assoc _ (rng_power x n)).
-  f_ap.
-Defined.
+Definition cring_quotient_map {R : CRing} (I : Ideal R)
+  : R $-> cring_quotient R I
+  := rng_quotient_map I.
diff --git a/theories/Algebra/Rings/ChineseRemainder.v b/theories/Algebra/Rings/ChineseRemainder.v
index 29597a8b12e..788ba59a8cc 100644
--- a/theories/Algebra/Rings/ChineseRemainder.v
+++ b/theories/Algebra/Rings/ChineseRemainder.v
@@ -1,10 +1,11 @@
-Require Import Classes.interfaces.abstract_algebra.
+Require Import Classes.interfaces.canonical_names.
 Require Import WildCat.
 Require Import Modalities.ReflectiveSubuniverse.
 Require Import Algebra.AbGroups.
-Require Import Algebra.Rings.CRing.
+Require Import Algebra.Rings.Ring.
 Require Import Algebra.Rings.Ideal.
 Require Import Algebra.Rings.QuotientRing.
+Require Import Algebra.Rings.CRing.
 
 (** * Chinese remainder theorem *)
 
@@ -17,18 +18,18 @@ Section ChineseRemainderTheorem.
   (** We assume [Univalence] in order to work with quotients. We also need it for [Funext] in a few places.*)
   Context `{Univalence}
     (** We need two coprime ideals [I] and [J] to state the theorem. We don't introduce the coprimeness assumption as of yet in order to show something slightly stronger. *)
-    {R : CRing} (I J : Ideal R).
+    {R : Ring} (I J : Ideal R).
 
   (** We begin with the homomorphism which will show to be a surjection. Using the first isomorphism theorem for rings we can improve this to be the isomorphism we want. *)
   (** This is the corecursion of the two quotient maps *)
   Definition rng_homo_crt : R $-> (R / I) × (R / J).
   Proof.
-    apply cring_product_corec.
+    apply ring_product_corec.
     1,2: apply rng_quotient_map.
   Defined.
 
   (** Since we are working with quotients, we make the following notation to make working with the proof somewhat easier. *)
-  Notation "[ x ]" := (rng_quotient_map _ x).
+  Local Notation "[ x ]" := (rng_quotient_map _ x).
 
   (** We then need to prove the following lemma. The hypotheses here can be derived by coprimality of [I] and [J]. But we don't need that here. *)
   Lemma issurjection_rng_homo_crt' (x y : R)
@@ -137,14 +138,16 @@ Section ChineseRemainderTheorem.
       1: exact (related_quotient_paths _ _ _ q).
   Defined.
 
-  (** We also have the same for products of ideals. *)
-  Theorem chinese_remainder_prod : R / (I ⋅ J)%ideal ≅ (R / I) × (R / J).
-  Proof.
-    etransitivity.
-    { rapply rng_quotient_invar.
-      symmetry.
-      rapply ideal_intersection_is_product. }
-    rapply chinese_remainder.
-  Defined.
-
 End ChineseRemainderTheorem.
+
+(** We also have the same for products of ideals when in a commuatative ring. *)
+Theorem chinese_remainder_prod `{Univalence}
+  {R : CRing} (I J : Ideal R) (c : Coprime I J)
+  : R / (I ⋅ J)%ideal ≅ (R / I) × (R / J).
+Proof.
+  etransitivity.
+  { rapply rng_quotient_invar.
+    symmetry.
+    rapply ideal_intersection_is_product. }
+  rapply chinese_remainder.
+Defined.
diff --git a/theories/Algebra/Rings/Ideal.v b/theories/Algebra/Rings/Ideal.v
index abae917766c..160c1205786 100644
--- a/theories/Algebra/Rings/Ideal.v
+++ b/theories/Algebra/Rings/Ideal.v
@@ -1,8 +1,10 @@
 Require Import Basics Types.
 Require Import Spaces.Finite.Fin.
-Require Import Classes.interfaces.abstract_algebra.
-Require Import Algebra.Rings.CRing.
+Require Import Classes.interfaces.canonical_names.
+Require Import Algebra.Rings.Ring.
+Require Import Algebra.Groups.Subgroup.
 Require Import Algebra.AbGroups.
+Require Import WildCat.Core.
 
 Local Open Scope mc_scope.
 
@@ -10,37 +12,124 @@ Declare Scope ideal_scope.
 Delimit Scope ideal_scope with ideal.
 Local Open Scope ideal_scope.
 
-(** In this file we define Ideals *)
+(** * Left, Right and Two-sided Ideals *)
 
-(** An additive subgroup I of a ring R is an ideal when: *)
-Class IsIdeal {R : CRing} (I : Subgroup R) :=
-  isideal (r x : R) : I x -> I (r * x).
+(** ** Definition of Ideals *)
 
-Global Instance ishprop_isideal `{Funext} {R : CRing} (I : Subgroup R)
-  : IsHProp (IsIdeal I) := ltac:(unfold IsIdeal; exact _).
+(** An additive subgroup [I] of a ring [R] is a left ideal when it is closed under multiplciation on the left. *)
+Class IsLeftIdeal {R : Ring} (I : Subgroup R) :=
+  isleftideal (r x : R) : I x -> I (r * x).
 
-(** An ideal of a ring [R] is a subgroup of R which is closed under left multiplication. *)
-Record Ideal (R : CRing) := {
-  ideal_subgroup : Subgroup R;
-  ideal_isideal : IsIdeal ideal_subgroup;
-}.
+(** An additive subgroup [I] of a ring [R] is a right ideal when it is closed under multiplication on the right. We define this using the opposite ring allowing us to reduce redundancy between left and right ideals. *)
+Class IsRightIdeal {R : Ring} (I : Subgroup R) :=
+  isrightideal_isleftideal_op :: IsLeftIdeal (R := rng_op R) I.
 
-Coercion ideal_subgroup : Ideal >-> Subgroup.
-Global Existing Instances ideal_isideal.
+Definition isrightideal {R : Ring} (I : Subgroup R) (x r : R)
+  : IsRightIdeal I -> I x -> I (x * r)
+  := fun _ => isleftideal (R := rng_op R) r x.
 
-Definition issig_Ideal (R : CRing) : _ <~> Ideal R := ltac:(issig).
+(** An additive subgroup [I] of a ring [R] is a two-sided ideal when it is both a left and right ideal. In this case we just call it an ideal. *)
+Class IsIdeal {R : Ring} (I : Subgroup R) := {
+  ideal_isleftideal :: IsLeftIdeal I;
+  ideal_isrightideal :: IsRightIdeal I;
+}.
+Definition issig_IsIdeal {R : Ring} (I : Subgroup R) : _ <~> IsIdeal I := ltac:(issig).
+Hint Immediate Build_IsIdeal : typeclass_instances.
 
-Global Instance ishset_ideal `{Univalence} {R : CRing} : IsHSet (Ideal R).
+(** Any two-sided ideal is also a two-sided ideal of the opposite ring. *)
+Global Instance isideal_op {R : Ring} (I : Subgroup R)
+  : IsIdeal I -> IsIdeal (R := rng_op R) I.
 Proof.
-  nrapply istrunc_equiv_istrunc.
-  1: apply issig_Ideal.
-  rapply istrunc_sigma.
+  intros [? ?]; exact _.
 Defined.
 
-(** Here are some lemmas for proving certain elements are in an ideal. They are just special cases of the underlying subgroup lemmas. We write them out for clarity. *)
+(** A left ideal of a ring [R] is a subgroup [I] of [R] which is closed under left multiplication. *)
+Record LeftIdeal (R : Ring) := {
+  leftideal_subgroup :> Subgroup R;
+  leftideal_isleftideal :: IsLeftIdeal leftideal_subgroup;
+}.
+Definition issig_LeftIdeal (R : Ring) : _ <~> LeftIdeal R := ltac:(issig).
+
+(** A right ideal of a ring [R] is a subgroup [I] of [R] which is closed under right multiplication. *)
+Definition RightIdeal (R : Ring) := LeftIdeal (rng_op R).
+
+Global Instance isrightdeal_rightideal {R} (I : RightIdeal R)
+  : IsRightIdeal (R:=R) I
+  := leftideal_isleftideal _ I.
+
+Definition Build_RightIdeal (R : Ring) (I : Subgroup R) (H : IsRightIdeal I)
+  : RightIdeal R
+  := Build_LeftIdeal (rng_op R) I H.
+
+Definition issig_RightIdeal (R : Ring)
+  : {I : Subgroup R& IsRightIdeal (R:=R) I} <~> RightIdeal R
+  := ltac:(issig).
+
+(** A two-sided ideal of a ring [R], or just an ideal, is a subgroup [I] of [R] which is closed under both left and right multiplication. *)
+Record Ideal (R : Ring) := {
+  ideal_subgroup :> Subgroup R;
+  ideal_isideal :: IsIdeal ideal_subgroup;
+}.
+Definition issig_Ideal (R : Ring) : _ <~> Ideal R := ltac:(issig).
+
+Definition ideal_op (R : Ring) : Ideal R -> Ideal (rng_op R)
+  := fun I => Build_Ideal (rng_op R) I _.
+Coercion ideal_op : Ideal >-> Ideal.
+
+(** *** Truncatedness properties *)
+
+Section IdealTrunc.
+  (** Assuming [Funext] we can show that the ideal predicates are propositions. *) 
+  Context `{Funext}.
+
+  (** Being a left ideal is a proposition. *)
+  Global Instance ishprop_isleftideal {R : Ring} (I : Subgroup R)
+    : IsHProp (IsLeftIdeal I) := ltac:(unfold IsLeftIdeal; exact _).
+
+  (** Being a right ideal is a proposition. *)
+  Global Instance ishprop_isrightideal `{Funext} {R : Ring} (I : Subgroup R)
+    : IsHProp (IsRightIdeal I) :=  ishprop_isleftideal _.
+
+  (** Being a two-sided ideal is a proposition. *)
+  Global Instance ishprop_isideal {R : Ring} (I : Subgroup R)
+    : IsHProp (IsIdeal I)
+    := istrunc_equiv_istrunc _ (issig_IsIdeal I).
+
+  (** Assuming [Univalence] we can show that the ideal types are sets. Note that univalence is only used to prove that the type of [Subgroup]s is a set. *)
+  Context `{Univalence}.
+
+  (** The type of left ideals is a set. *)
+  Global Instance ishset_leftideal {R : Ring} : IsHSet (LeftIdeal R)
+    := istrunc_equiv_istrunc _ (issig_LeftIdeal R).
+  
+  (** The type of right ideals is a set. *)
+  Global Instance ishset_rightideal {R : Ring} : IsHSet (RightIdeal R)
+    := _.
+
+  (** The type of ideals is a set. *)
+  Global Instance ishset_ideal {R : Ring} : IsHSet (Ideal R)
+    := istrunc_equiv_istrunc _ (issig_Ideal R).
+
+End IdealTrunc.
+
+(** *** Conversion between Ideals *)
+
+(** Every ideal is a left ideal. *)
+Definition leftideal_of_ideal {R : Ring} : Ideal R -> LeftIdeal R
+  := fun I => Build_LeftIdeal R I _.
+Coercion leftideal_of_ideal : Ideal >-> LeftIdeal.
+
+(** Every ideal is a right ideal. *)
+Definition rightideal_of_ideal {R : Ring} : Ideal R -> RightIdeal R
+  := fun I => Build_RightIdeal R I _.
+Coercion rightideal_of_ideal : Ideal >-> RightIdeal.
+
+(** *** Easy properties of ideals *)
+
+(** Here are some lemmas for proving certain elements are in an ideal. They are just special cases of the underlying subgroup lemmas. We write them out for clarity. Note that [I] isn't actually assumed to be an ideal but only a subgroup. *)
 Section IdealElements.
-  Context {R : CRing} (I : Ideal R) (a b : R).
-  Definition ideal_in_zero : I cring_zero := subgroup_in_unit I.
+  Context {R : Ring} (I : Subgroup R) (a b : R).
+  Definition ideal_in_zero : I ring_zero := subgroup_in_unit I.
   Definition ideal_in_plus : I a -> I b -> I (a + b) := subgroup_in_op I a b.
   Definition ideal_in_negate  : I a -> I (- a) := subgroup_in_inv  I a.
   Definition ideal_in_negate' : I (- a) -> I a := subgroup_in_inv' I a.
@@ -50,67 +139,143 @@ Section IdealElements.
   Definition ideal_in_plus_r : I (a + b) -> I a -> I b := subgroup_in_op_r I a b.
 End IdealElements.
 
-(** The zero ideal is an ideal *)
-Global Instance isideal_trivial_subgroup (R : CRing)
-  : IsIdeal (R:=R) trivial_subgroup.
+(** ** Constructions of ideals *)
+
+(** *** Zero Ideal *)
+
+(** The trivial subgroup is a left ideal. *)
+Global Instance isleftideal_trivial_subgroup (R : Ring)
+  : IsLeftIdeal (R := R) trivial_subgroup.
 Proof.
-  hnf; cbn. intros r x p.
-  refine (_ @ rng_mult_zero_r r).
+  intros r x p.
+  rhs_V nrapply (rng_mult_zero_r).
   f_ap.
 Defined.
 
-(** Zero ideal *)
-Definition ideal_zero (R : CRing) : Ideal R
-  := Build_Ideal R _ (isideal_trivial_subgroup R).
+(** The trivial subgroup is a right ideal. *)
+Global Instance isrightideal_trivial_subgroup (R : Ring)
+  : IsRightIdeal (R := R) trivial_subgroup
+  := isleftideal_trivial_subgroup _.
 
-(** The unit ideal is an ideal *)
-Global Instance isideal_maximal_subgroup (R : CRing)
-  : IsIdeal (R:=R) maximal_subgroup.
-Proof.
-  split.
-Defined.
+(** The trivial subgroup is an ideal. *)
+Global Instance isideal_trivial_subgroup (R : Ring)
+  : IsIdeal (R := R) trivial_subgroup
+  := {}.
+
+(** We call the trivial subgroup the "zero ideal". *)
+Definition ideal_zero (R : Ring) : Ideal R := Build_Ideal R _ _. 
+
+(** *** The unit ideal *)
+
+(** The maximal subgroup is a left ideal. *)
+Global Instance isleftideal_maximal_subgroup (R : Ring)
+  : IsLeftIdeal (R := R) maximal_subgroup
+  := ltac:(done).
 
-(** Unit ideal *)
-Definition ideal_unit (R : CRing) : Ideal R
+(** The maximal subgroup is a right ideal. *)
+Global Instance isrightideal_maximal_subgroup (R : Ring)
+  : IsRightIdeal (R := R) maximal_subgroup
+  := isleftideal_maximal_subgroup _.
+
+(** The maximal subgroup is an ideal.  *)
+Global Instance isideal_maximal_subgroup (R : Ring)
+  : IsIdeal (R:=R) maximal_subgroup
+  := {}.
+
+(** We call the maximal subgroup the "unit ideal". *)
+Definition ideal_unit (R : Ring) : Ideal R
   := Build_Ideal R _ (isideal_maximal_subgroup R).
 
-(** Intersections of underlying subgroups of ideals are again ideals *)
-Global Instance isideal_subgroup_intersection (R : CRing) (I J : Ideal R)
-  : IsIdeal (subgroup_intersection I J).
+(** *** Intersection of ideals *)
+
+(** Intersections of underlying subgroups of left ideals are again left ideals. *)
+Global Instance isleftideal_subgroup_intersection (R : Ring) (I J : Subgroup R)
+  `{IsLeftIdeal R I, IsLeftIdeal R J}
+  : IsLeftIdeal (subgroup_intersection I J).
 Proof.
-  intros r x [a b]; split; by apply isideal.
+  intros r x [a b]; split; by apply isleftideal.
 Defined.
 
-(** Intersection of ideals *)
-Definition ideal_intersection {R : CRing} : Ideal R -> Ideal R -> Ideal R
-  := fun I J => Build_Ideal R _ (isideal_subgroup_intersection R I J).
-
-(** The subgroup product of ideals is again an ideal. *)
-Global Instance isideal_subgroup_product (R : CRing) (I J : Ideal R)
-  : IsIdeal (subgroup_product I J).
+(** Intersections of underlying subgroups of right ideals are again right ideals. *)
+Global Instance isrightideal_subgroup_intersection (R : Ring) (I J : Subgroup R)
+  `{IsRightIdeal R I, IsRightIdeal R J}
+  : IsRightIdeal (subgroup_intersection I J)
+  := isleftideal_subgroup_intersection _ _ _.
+
+(** Intersections of underlying subgroups of ideals are again ideals. *)
+Global Instance isideal_subgroup_intersection (R : Ring) (I J : Subgroup R)
+  `{IsIdeal R I, IsIdeal R J}
+  : IsIdeal (subgroup_intersection I J)
+  := {}.
+
+(** Intersection of left ideals. *)
+Definition leftideal_intersection {R : Ring}
+  : LeftIdeal R -> LeftIdeal R -> LeftIdeal R
+  := fun I J => Build_LeftIdeal R (subgroup_intersection I J) _.
+
+(** Intersection of right ideals. *)
+Definition rightideal_intersection {R : Ring}
+  : RightIdeal R -> RightIdeal R -> RightIdeal R
+  := leftideal_intersection.
+
+(** Intersection of ideals. *)
+Definition ideal_intersection {R : Ring}
+  : Ideal R -> Ideal R -> Ideal R
+  := fun I J => Build_Ideal R (subgroup_intersection I J) _.
+
+(** *** Sum of ideals *)
+
+(** The subgroup product of left ideals is again an ideal. *)
+Global Instance isleftideal_subgroup_product (R : Ring) (I J : Subgroup R)
+  `{IsLeftIdeal R I, IsLeftIdeal R J}
+  : IsLeftIdeal (subgroup_product I J).
 Proof.
   intros r.
-  refine (subgroup_product_ind I J _  _ _ _ _).
-  + intros x p.
+  nrapply subgroup_product_ind.
+  - intros x p.
     apply tr, sgt_in.
-    left; by apply isideal.
-  + intros x p.
+    left; by apply isleftideal.
+  - intros x p.
     apply tr, sgt_in.
-    right; by apply isideal.
-  + apply tr, sgt_in.
-    left; apply isideal.
+    right; by apply isleftideal.
+  - apply tr, sgt_in.
+    left; apply isleftideal.
     apply ideal_in_zero.
-  + intros x y p q IHp IHq.
+  - intros x y p q IHp IHq; cbn beta.
     rewrite rng_dist_l.
     rewrite rng_mult_negate_r.
-    by rapply subgroup_in_op_inv.
+    by apply subgroup_in_op_inv.
+  - exact _.
 Defined.
 
-(** Sum of ideals *)
-Definition ideal_sum {R : CRing} : Ideal R -> Ideal R -> Ideal R
-  := fun I J => Build_Ideal R _ (isideal_subgroup_product R I J).
+(** The subgroup product of right ideals is again an ideal. *)
+Global Instance isrightideal_subgroup_product (R : Ring) (I J : Subgroup R)
+  `{IsRightIdeal R I, IsRightIdeal R J}
+  : IsRightIdeal (subgroup_product I J)
+  := isleftideal_subgroup_product _ _ _.
 
-Definition ideal_sum_ind {R : CRing} (I J : Ideal R)
+(** The subgroup product of ideals is again an ideal. *)
+Global Instance isideal_subgroup_product (R : Ring) (I J : Subgroup R)
+  `{IsIdeal R I, IsIdeal R J}
+  : IsIdeal (subgroup_product I J)
+  := {}.
+
+(** Sum of left ideals. *)
+Definition leftideal_sum {R : Ring}
+  : LeftIdeal R -> LeftIdeal R -> LeftIdeal R
+  := fun I J => Build_LeftIdeal R (subgroup_product I J) _.
+
+(** Sum of right ideals. *)
+Definition rightideal_sum {R : Ring}
+  : RightIdeal R -> RightIdeal R -> RightIdeal R
+  := leftideal_sum.
+
+(** Sum of ideals. *)
+Definition ideal_sum {R : Ring}
+  : Ideal R -> Ideal R -> Ideal R
+  := fun I J => Build_Ideal R (subgroup_product I J) _.
+
+Definition ideal_sum_ind {R : Ring} (I J : Ideal R)
   (P : forall x, ideal_sum I J x -> Type)
   (P_I_in : forall x y, P x (tr (sgt_in (inl y))))
   (P_J_in : forall x y, P x (tr (sgt_in (inr y))))
@@ -122,251 +287,493 @@ Definition ideal_sum_ind {R : CRing} (I J : Ideal R)
 
 (** *** Product of ideals *)
 
-(** First we form the "naive" product of ideals { a * b | a ∈ I /\ b ∈ J } *)
-(** Note that this is not an ideal, but we can fix this later. *)
-Inductive ideal_product_naive_type {R : CRing} (I J : Ideal R) : R -> Type :=
-| ipn_in : forall x y, I x -> J y -> ideal_product_naive_type I J (x * y)
-.
+(** First we form the "naive" product of ideals { a * b | a ∈ I /\ b ∈ J }. Note that this is not an ideal, but we can fix this. *)
+Inductive ideal_product_naive_type {R : Ring} (I J : Subgroup R) : R -> Type :=
+| ipn_in : forall x y, I x -> J y -> ideal_product_naive_type I J (x * y).
 
-(** Now we can close this under addition to get the product ideal. *)
+(** We instead consider the subgroup generated by this naive product and later prove it happens to be an ideal. Note that the subgroup generated by a set and the ideal generated by a set are not the same in general. *)
+Definition ideal_product_type {R : Ring} (I J : Subgroup R) : Subgroup R
+  := subgroup_generated (G := R) (ideal_product_naive_type I J). 
 
-(** Product of ideals *)
-Definition ideal_product {R : CRing} : Ideal R -> Ideal R -> Ideal R.
+(** The product of left ideals is a left ideal. *)
+Global Instance isleftideal_ideal_product_type {R : Ring} (I J : Subgroup R)
+  `{IsLeftIdeal R I, IsLeftIdeal R J}
+  : IsLeftIdeal (ideal_product_type I J).
 Proof.
-  intros I J.
-  snrapply Build_Ideal.
-  1: exact (subgroup_generated (G := R) (ideal_product_naive_type I J)).
-  intros r s.
-  apply Trunc_functor.
-  intros p.
-  induction p as [s i | | g h p1 IHp1 p2 IHp2].
-  + destruct i.
-    apply sgt_in.
-    rewrite simple_associativity.
-    apply ipn_in.
-    1: apply isideal.
-    1,2: assumption.
-  + rewrite rng_mult_zero_r.
-    rapply sgt_unit.
-  + rewrite rng_dist_l.
-    rewrite rng_mult_negate_r.
-    by rapply sgt_op.
+  intro r.
+  nrapply (functor_subgroup_generated _ _ (grp_homo_rng_left_mult r)).
+  intros s [s1 s2 p1 p2]; cbn.
+  rewrite simple_associativity.
+  nrefine (ipn_in I J (r * s1) s2 _ p2).
+  by apply isleftideal.
 Defined.
 
-(** The kernel of a ring homomorphism is an ideal. *)
-Definition ideal_kernel {R S : CRing} (f : CRingHomomorphism R S) : Ideal R.
+(** The product of right ideals is a right ideal. *)
+Global Instance isrightideal_ideal_product_type {R : Ring} (I J : Subgroup R)
+  `{IsRightIdeal R I, IsRightIdeal R J}
+  : IsRightIdeal (ideal_product_type I J).
 Proof.
-  snrapply Build_Ideal.
-  1: exact (grp_kernel f).
-  intros r x p; cbn in p.
-  simpl.
-  refine (rng_homo_mult _ _ _ @ _).
-  refine (_ @ rng_mult_zero_r (f r)).
-  f_ap.
+  intro r.
+  nrapply (functor_subgroup_generated _ _ (grp_homo_rng_right_mult (R:=R) r)).
+  intros s [s1 s2 p1 p2]; cbn.
+  rewrite <- simple_associativity.
+  nrefine (ipn_in I J s1 (s2 * r) p1 _).
+  by apply isrightideal.
 Defined.
 
+(** The product of ideals is an ideal. *)
+Global Instance isideal_ideal_product_type {R : Ring} (I J : Subgroup R)
+  `{IsIdeal R I, IsIdeal R J}
+  : IsIdeal (ideal_product_type I J)
+  := {}. 
+
+(** Product of left ideals. *)
+Definition leftideal_product {R : Ring}
+  : LeftIdeal R -> LeftIdeal R -> LeftIdeal R
+  := fun I J => Build_LeftIdeal R (ideal_product_type I J) _.
+
+(** Product of right ideals. *)
+Definition rightideal_product {R : Ring}
+  : RightIdeal R -> RightIdeal R -> RightIdeal R
+  := leftideal_product.
+
+(** Product of ideals. *)
+Definition ideal_product {R : Ring}
+  : Ideal R -> Ideal R -> Ideal R
+  := fun I J => Build_Ideal R (ideal_product_type I J) _.
+
+(** *** The kernel of a ring homomorphism *)
+
+(** The kernel of the underlying group homomorphism of a ring homomorphism is a left ideal. *)
+Global Instance isleftideal_grp_kernel {R S : Ring} (f : RingHomomorphism R S)
+  : IsLeftIdeal (grp_kernel f).
+Proof.
+  intros r x p.
+  lhs nrapply rng_homo_mult.
+  rhs_V nrapply (rng_mult_zero_r (f r)).
+  by apply ap.
+Defined.
+
+(** The kernel of the underlying group homomorphism of a ring homomorphism is a right ideal. *)
+Global Instance isrightideal_grp_kernel {R S : Ring} (f : RingHomomorphism R S)
+  : IsRightIdeal (grp_kernel f)
+  := isleftideal_grp_kernel (fmap rng_op f).
+
+(** The kernel of the underlying group homomorphism of a ring homomorphism is an ideal. *)
+Global Instance isideal_grp_kernel {R S : Ring} (f : RingHomomorphism R S)
+  : IsIdeal (grp_kernel f)
+  := {}.
+
+(** The kernel of a ring homomorphism is an ideal. *)
+Definition ideal_kernel {R S : Ring} (f : RingHomomorphism R S) : Ideal R
+  := Build_Ideal R (grp_kernel f) _.
+
 (** *** Ideal generated by a subset *)
 
-(** It seems tempting to define ideals generated by a subset in terms of subgroups generated by a subset but this does not work. Ideals also have to be closed under left multiplciation by ring elements so they end up having more elements than the subgroup that gets generated. *)
+(** It seems tempting to define ideals generated by a subset in terms of subgroups generated by a subset but this does not work. Left ideals also have to be closed under left multiplciation by ring elements, and similarly for right and two sided ideals. Therefore we will do an analagous construction to the one done in Subgroup.v. *)
 
-(** Therefore we will do an analagous construction to the one done in Subgroup.v *)
+(** Underlying type family of a left ideal generated by subset. *)
+Inductive leftideal_generated_type (R : Ring) (X : R -> Type) : R -> Type :=
+(** It should contain all elements of the original family. *)
+| ligt_in (r : R) : X r -> leftideal_generated_type R X r
+(** It should contain zero. *)
+| ligt_zero : leftideal_generated_type R X ring_zero
+(** It should be closed under negation and addition. *)
+| ligt_add_neg (r s : R)
+  : leftideal_generated_type R X r
+  -> leftideal_generated_type R X s
+  -> leftideal_generated_type R X (r - s)
+(** And finally, it should be closed under left multiplication. *)
+| ligt_mul (r s : R)
+  : leftideal_generated_type R X s
+  -> leftideal_generated_type R X (r * s)
+.
+
+Arguments leftideal_generated_type {R} X r.
+Arguments ligt_in {R X r}.
+Arguments ligt_zero {R X}.
+Arguments ligt_add_neg {R X r s}.
+Arguments ligt_mul {R X r s}.
 
-(** Underlying type family of an ideal generated by subset *)
-Inductive ideal_generated_type (R : CRing) (X : R -> Type) : R -> Type :=
-(** The iddeal should contain all elements of the original family. *)
+(** Left ideal generated by a subset. *)
+Definition leftideal_generated {R : Ring} (X : R -> Type) : LeftIdeal R.
+Proof.
+  snrapply Build_LeftIdeal.
+  - snrapply Build_Subgroup'.
+    + exact (fun x => merely (leftideal_generated_type X x)).
+    + exact _.
+    + apply tr, ligt_zero.
+    + intros x y p q; strip_truncations.
+      by apply tr, ligt_add_neg.
+  - intros r x; apply Trunc_functor.
+    apply ligt_mul.
+Defined.
+
+(** Right ideal generated by a subset. *)
+Definition rightideal_generated {R : Ring} (X : R -> Type) : RightIdeal R
+  := Build_RightIdeal R (leftideal_generated (R:=rng_op R) X) _.
+
+(** Underlying type family of a two-sided ideal generated by subset. *)
+Inductive ideal_generated_type (R : Ring) (X : R -> Type) : R -> Type :=
+(** It should contain all elements of the original family. *)
 | igt_in (r : R) : X r -> ideal_generated_type R X r
 (** It should contain zero. *)
-| igt_zero : ideal_generated_type R X cring_zero
+| igt_zero : ideal_generated_type R X ring_zero
 (** It should be closed under negation and addition. *)
 | igt_add_neg (r s : R)
   : ideal_generated_type R X r
   -> ideal_generated_type R X s
   -> ideal_generated_type R X (r - s)
-(** And finally, it should be closed under left multiplication. *)
-| igt_mul (r s : R)
+(** And finally, it should be closed under left and right multiplication. *)
+| igt_mul_l (r s : R)
   : ideal_generated_type R X s
   -> ideal_generated_type R X (r * s)
+| igt_mul_r (r s : R)
+  : ideal_generated_type R X r
+  -> ideal_generated_type R X (r * s)
 .
 
 Arguments ideal_generated_type {R} X r.
 Arguments igt_in {R X r}.
 Arguments igt_zero {R X}.
 Arguments igt_add_neg {R X r s}.
-Arguments igt_mul {R X r s}.
-
-(** Again, as with subgroups we need to truncate this to make it a predicate. *)
+Arguments igt_mul_l {R X r s}.
+Arguments igt_mul_r {R X r s}.
 
-(** Ideal generated by a subset *)
-Definition ideal_generated {R : CRing} (X : R -> Type) : Ideal R.
+(** Two-sided ideal generated by a subset. *)
+Definition ideal_generated {R : Ring} (X : R -> Type) : Ideal R.
 Proof.
-  snrapply Build_Ideal.
-  { snrapply Build_Subgroup'.
-    1: exact (fun x => merely (ideal_generated_type X x)).
-    1: exact _.
-    1: apply tr, igt_zero.
-    intros x y p q; strip_truncations.
-    by apply tr, igt_add_neg. }
-  intros r x; apply Trunc_functor.
-  apply igt_mul.
-Defined.
-
-(** Finitely generated ideal *)
-Definition ideal_generated_finite {R : CRing} {n : nat} (X : Fin n -> R) : Ideal R.
+  snrapply Build_Ideal; [|split].
+  - snrapply Build_Subgroup'.
+    + exact (fun x => merely (ideal_generated_type X x)).
+    + exact _.
+    + apply tr, igt_zero.
+    + intros x y p q; strip_truncations.
+      by apply tr, igt_add_neg.
+  - intros r x; apply Trunc_functor.
+    nrapply igt_mul_l.
+  - intros x r; apply Trunc_functor.
+    nrapply igt_mul_r.
+Defined. 
+
+(** *** Finitely gnerated ideal. *)
+
+(** Finitely generated ideals *)
+Definition ideal_generated_finite {R : Ring} {n : nat} (X : Fin n -> R) : Ideal R.
 Proof.
   apply ideal_generated.
-  intros r.
-  exact {x : Fin n & X x = r}.
+  exact (hfiber X).
 Defined.
 
-(** Principal ideal *)
-Definition ideal_principal {R : CRing} (x : R) : Ideal R
+(** *** Principal ideals *)
+
+(** A principal ideal is an ideal generated by a single element. *)
+Definition ideal_principal {R : Ring} (x : R) : Ideal R
   := ideal_generated (fun r => x = r).
 
 (** *** Ideal equality *)
 
 (** Classically, set based equality suffices for ideals. Since we are talking about predicates, we use pointwise iffs. This can of course be shown to be equivalent to the identity type. *)
-Definition ideal_eq {R : CRing} (I J : Ideal R) := forall x, I x <-> J x.
+Definition ideal_eq {R : Ring} (I J : Subgroup R) := forall x, I x <-> J x.
 
-(** With univalence we can characterize paths of ideals *)
-Lemma equiv_path_ideal `{Univalence} {R : CRing} {I J : Ideal R} : ideal_eq I J <~> I = J.
+(** With univalence we can characterize equality of ideals. *)
+Lemma equiv_path_ideal `{Univalence} {R : Ring} {I J : Ideal R} : ideal_eq I J <~> I = J.
 Proof.
   refine ((equiv_ap' (issig_Ideal R)^-1 _ _)^-1 oE _).
   refine (equiv_path_sigma_hprop _ _ oE _).
   rapply equiv_path_subgroup'.
 Defined.
 
-Global Instance ishprop_ideal_eq `{Funext} {R : CRing} (I J : Ideal R)
+(** Under funext, ideal equiality is a proposition. *)
+Global Instance ishprop_ideal_eq `{Funext} {R : Ring} (I J : Ideal R)
   : IsHProp (ideal_eq I J) := _.
 
-Global Instance reflexive_ideal_eq {R : CRing} : Reflexive (@ideal_eq R).
+(** Ideal equality is reflexive. *)
+Global Instance reflexive_ideal_eq {R : Ring} : Reflexive (@ideal_eq R).
 Proof.
   intros I x; by split.
 Defined.
 
-Global Instance symmetric_ideal_eq {R : CRing} : Symmetric (@ideal_eq R).
+(** Ideal equality is symmetric. *)
+Global Instance symmetric_ideal_eq {R : Ring} : Symmetric (@ideal_eq R).
 Proof.
   intros I J p x; specialize (p x); by symmetry.
 Defined.
 
-Global Instance transitive_ideal_eq {R : CRing} : Transitive (@ideal_eq R).
+(** Ideal equality is transitive. *)
+Global Instance transitive_ideal_eq {R : Ring} : Transitive (@ideal_eq R).
 Proof.
   intros I J K p q x; specialize (p x); specialize (q x); by transitivity (J x).
 Defined.
 
+(** *** Subset relation on ideals *)
+
 (** We define the subset relation on ideals in the usual way: *)
-Definition ideal_subset {R : CRing} (I J : Ideal R) := (forall x, I x -> J x).
+Definition ideal_subset {R : Ring} (I J : Subgroup R) := (forall x, I x -> J x).
 
-Global Instance reflexive_ideal_subset {R : CRing} : Reflexive (@ideal_subset R)
+(** The subset relation is reflexive. *)
+Global Instance reflexive_ideal_subset {R : Ring} : Reflexive (@ideal_subset R)
   := fun _ _ => idmap.
 
-Global Instance transitive_ideal_subset {R : CRing} : Transitive (@ideal_subset R).
+(** The subset relation is transitive. *)
+Global Instance transitive_ideal_subset {R : Ring} : Transitive (@ideal_subset R).
 Proof.
   intros x y z p q a.
-  specialize (p a); specialize (q a).
-  exact (q o p).
+  exact (q a o p a).
 Defined.
 
-Coercion ideal_eq_subset {R : CRing} {I J : Ideal R} : ideal_eq I J -> ideal_subset I J.
+(** We can coerce equality to the subset relation, since equality is defined to be the subset relation in each direction. *)
+Coercion ideal_eq_subset {R : Ring} {I J : Subgroup R} : ideal_eq I J -> ideal_subset I J.
 Proof.
   intros f x; apply f.
 Defined.
 
-(** Quotient (a.k.a colon) ideal *)
-(** Note that this is quotient as in division rather than a colimit. In fact, the quotient ideal is more like an internal hom as we will see later. *)
-(** Unfortunately, due to truncatedness constraints, we need to assume funext. *)
-Definition ideal_quotient `{Funext} {R : CRing} (I J : Ideal R) : Ideal R.
+(** *** Quotient (a.k.a colon) ideals *)
+
+(** The definitions here are not entirely standard, but will become so when considering only commutative rings. For the non-commutative case there isn't a lot written about ideal quotients. *)
+
+(** The subgroup corresponding to the left ideal quotient. *)
+Definition subgroup_leftideal_quotient {R : Ring} (I J : Subgroup R)
+  : Subgroup R.
 Proof.
-  snrapply Build_Ideal.
-  { snrapply Build_Subgroup'.
-    1: exact (fun r => forall x, J x -> I (r * x)).
-    1: exact _.
-    { intros r p.
-      rewrite rng_mult_zero_l.
-      apply ideal_in_zero. }
-    hnf; intros x y p q r s.
+  snrapply Build_Subgroup'.
+  - exact (fun r => merely (forall x, J x -> I (r * x))).
+  - exact _.
+  - apply tr.
+    intros r p.
+    rewrite rng_mult_zero_l.
+    apply ideal_in_zero.
+  - intros x y p q.
+    strip_truncations; apply tr.
+    hnf; intros s j.
     rewrite rng_dist_r.
     rewrite rng_mult_negate_l.
     apply ideal_in_plus_negate.
-    1: by apply p.
-    by apply q. }
-  hnf; cbn.
-  intros r x p q s.
+    + by apply p.
+    + by apply q.
+Defined.
+
+(** The left ideal quotient of a left ideal is a left ideal. *)
+Global Instance isleftideal_subgroup_leftideal_quotient {R : Ring}
+  (I J : Subgroup R) `{IsLeftIdeal R I}
+  : IsLeftIdeal (subgroup_leftideal_quotient I J).
+Proof.
+  intros r x p.
+  strip_truncations; apply tr.
+  intros s j.
+  rewrite <- rng_mult_assoc.
+  apply isleftideal.
+  by nrapply p.
+Defined.
+
+(** The left ideal quotient of a right ideal by a left ideal is a right ideal. *)
+Global Instance isrightideal_subgroup_leftideal_quotient {R : Ring}
+  (I J : Subgroup R) `{IsRightIdeal R I, IsLeftIdeal R J}
+  : IsRightIdeal (subgroup_leftideal_quotient (R:=R) I J).
+Proof.
+  intros r x p.
+  strip_truncations; apply tr.
+  intros s j.
+  cbn in *.
+  rewrite <- rng_mult_assoc.
+  apply p.
+  by rapply isleftideal.
+Defined.
+
+(** We define the left ideal quotient as a left ideal. *)
+Definition leftideal_quotient {R : Ring}
+  : LeftIdeal R -> Subgroup R -> LeftIdeal R
+  := fun I J => Build_LeftIdeal R (subgroup_leftideal_quotient I J) _.
+  
+Definition subgroup_rightideal_quotient {R : Ring} (I J : Subgroup R) : Subgroup R
+  := subgroup_leftideal_quotient (R:=rng_op R) I J. 
+
+Global Instance isrightideal_subgroup_rightideal_quotient {R : Ring}
+  (I J : Subgroup R) `{IsRightIdeal R I}
+  : IsRightIdeal (subgroup_rightideal_quotient I J)
+  := isleftideal_subgroup_leftideal_quotient (R:=rng_op R) I J.
+
+Global Instance isleftideal_subgroup_rightideal_quotient {R : Ring}
+  (I J : Subgroup R) `{H : IsLeftIdeal R I, IsRightIdeal R J}
+  : IsLeftIdeal (subgroup_rightideal_quotient I J).
+Proof.
+  snrapply (isrightideal_subgroup_leftideal_quotient (R:=rng_op R) I J).
+  - exact H.
+  - exact _.
+Defined.
+
+(** We define the right ideal quotient as a right ideal. *)
+Definition rightideal_quotient {R : Ring}
+  : RightIdeal R -> Subgroup R -> RightIdeal R
+  := fun I J => Build_RightIdeal R (subgroup_rightideal_quotient (R:=R) I J) _.
+
+(** The ideal quotient is then the intersection of a left and right quotient of both two sided ideals. *)
+Definition ideal_quotient {R : Ring}
+  : Ideal R -> Ideal R -> Ideal R
+  := fun I J =>
+    Build_Ideal R
+      (subgroup_intersection
+        (leftideal_quotient I J)
+        (rightideal_quotient I J))
+      (Build_IsIdeal _ _ _ _).
+
+(** *** Annihilator *)
+
+(** The left annihilator of a subset is the set of elements that annihilate the subgroup with left multiplication. *)
+Definition subgroup_ideal_left_annihilator {R : Ring} (S : R -> Type)
+  : Subgroup R.
+Proof.
+  snrapply Build_Subgroup'.
+  (** If we assume [Funext], then it isn't necessary to use [merely] here. *)
+  - exact (fun r => merely (forall x, S x -> r * x = ring_zero)).
+  - exact _.
+  - apply tr. 
+    intros r p.
+    apply rng_mult_zero_l.
+  - intros x y p q.
+    strip_truncations; apply tr.
+    intros r s.
+    lhs rapply rng_dist_r.
+    rewrite (p r s).
+    rewrite rng_mult_negate_l.
+    rewrite (q r s).
+    rewrite <- rng_mult_negate.
+    rewrite rng_mult_zero_r.
+    apply left_identity.
+Defined.
+
+(** The left annihilator of a subgroup of a ring is a left ideal of the ring. *)
+Global Instance isleftideal_ideal_left_annihilator {R : Ring} (I : R -> Type)
+  : IsLeftIdeal (subgroup_ideal_left_annihilator I).
+Proof.
+  intros r x p.
+  strip_truncations; apply tr.
+  intros s i.
+  rewrite <- rng_mult_assoc, (p s i).
+  apply rng_mult_zero_r.
+Defined.
+
+(** The left annihilator of a left ideal also happens to be a right ideal. In fact, left ideal could be weakened to subset closed under multplication, however we don't need this generality currently. *)
+Global Instance isrightideal_ideal_left_annihilator {R : Ring} (I : Subgroup R)
+  `{IsLeftIdeal R I}
+  : IsRightIdeal (subgroup_ideal_left_annihilator I).
+Proof.
+  intros r x p.
+  strip_truncations; apply tr.
+  intros s i; cbn.
   rewrite <- rng_mult_assoc.
-  by apply isideal, p.
+  by apply p, isleftideal.
 Defined.
 
-(** The annihilator of an ideal. *)
-Definition ideal_annihilator `{Funext} {R : CRing} (I : Ideal R) : Ideal R
-  := ideal_quotient (ideal_zero R) I.
+(** Therefore the annihilator of a left ideal is an ideal. *)
+Global Instance isideal_ideal_left_annihilator {R : Ring} (I : Subgroup R)
+  `{IsLeftIdeal R I}
+  : IsIdeal (subgroup_ideal_left_annihilator I)
+  := {}.
+
+(** The left annihilator of a left ideal. *)
+Definition ideal_left_annihilator {R : Ring} (I : LeftIdeal R) : Ideal R
+  := Build_Ideal R (subgroup_ideal_left_annihilator I) _.
+
+(** The right annihilator of a subset of a ring is the set of elements that annihilate the elements of the subset with right multiplication. *)
+Definition subgroup_ideal_right_annihilator {R : Ring} (I : R -> Type)
+  : Subgroup R
+  := subgroup_ideal_left_annihilator (R:=rng_op R) I.
+
+(** When the subset is a right ideal the right annihilator is a left ideal of the ring. This can be strengthened. See the comment in the left ideal version of this lemma above. *)
+Global Instance isleftideal_ideal_right_annihilator {R : Ring} (I : Subgroup R)
+  `{IsRightIdeal R I}
+  : IsLeftIdeal (subgroup_ideal_right_annihilator I)
+  := isrightideal_ideal_left_annihilator (R:=rng_op R) I.
+
+(** The right annihilator is a right ideal of the ring. *)
+Global Instance isrightideal_ideal_right_annihilator {R : Ring} (I : R -> Type)
+  : IsRightIdeal (subgroup_ideal_right_annihilator (R:=R) I)
+  := isleftideal_ideal_left_annihilator (R:=rng_op R) I.
+
+(** Therefore the annihilator of a right ideal is an ideal. *)
+Global Instance isideal_ideal_right_annihilator {R : Ring} (I : Subgroup R)
+  `{IsRightIdeal R I}
+  : IsIdeal (subgroup_ideal_right_annihilator (R:=R) I)
+  := {}.
+
+(** The right annihilator of a right ideal. *)
+Definition ideal_right_annihilator {R : Ring} (I : RightIdeal R) : Ideal R
+  := Build_Ideal R (subgroup_ideal_right_annihilator (R:=R) I)
+     (isideal_ideal_right_annihilator (R:=R) I).
+
+(** The annihilator of an ideal is the intersection of the left and right annihilators. *)
+Definition ideal_annihilator {R : Ring} (I : Ideal R) : Ideal R
+  := ideal_intersection (ideal_left_annihilator I) (ideal_right_annihilator I).
 
 (** ** Properties of ideals *)
 
 (** *** Coprime ideals *)
 
 (** Two ideals are coprime if their sum is the unit ideal. *)
-Definition Coprime {R : CRing} (I J : Ideal R) : Type
+Definition Coprime {R : Ring} (I J : Ideal R) : Type
   := ideal_eq (ideal_sum I J) (ideal_unit R).
 Existing Class Coprime.
 
-Global Instance ishprop_coprime `{Funext} {R : CRing}
+Global Instance ishprop_coprime `{Funext} {R : Ring}
   (I J : Ideal R) : IsHProp (Coprime I J).
 Proof.
     unfold Coprime.
     exact _.
 Defined.
 
-Lemma equiv_coprime_sum `{Funext} {R : CRing} (I J : Ideal R)
+Lemma equiv_coprime_sum `{Funext} {R : Ring} (I J : Ideal R)
   : Coprime I J
   <~> hexists (fun '(((i ; p) , (j ; q)) : sig I * sig J)
-      => i + j = cring_one).
+      => i + j = ring_one).
 Proof.
   simpl.
   srapply equiv_iff_hprop.
-  { intros c.
-    pose (snd (c cring_one) tt) as d; clearbody d; clear c.
+  - intros c.
+    pose (snd (c ring_one) tt) as d; clearbody d; clear c.
     strip_truncations.
     apply tr.
     induction d.
-    - destruct x.
-      + exists ((g ; s), (cring_zero; ideal_in_zero _)).
+    + destruct x.
+      * exists ((g ; s), (ring_zero; ideal_in_zero _)).
         apply rng_plus_zero_r.
-      + exists ((cring_zero; ideal_in_zero _), (g ; s)).
+      * exists ((ring_zero; ideal_in_zero _), (g ; s)).
         apply rng_plus_zero_l.
-    - exists ((cring_zero; ideal_in_zero _), (cring_zero; ideal_in_zero _)).
+    + exists ((ring_zero; ideal_in_zero _), (ring_zero; ideal_in_zero _)).
       apply rng_plus_zero_l.
-    - destruct IHd1 as [[[x xi] [y yj]] p].
+    + destruct IHd1 as [[[x xi] [y yj]] p].
       destruct IHd2 as [[[w wi] [z zj]] q].
       srefine (((_;_),(_;_));_).
-      + exact (x - w).
-      + by apply ideal_in_plus_negate.
-      + exact (y - z).
-      + by apply ideal_in_plus_negate.
-      + cbn.
+      * exact (x - w).
+      * by apply ideal_in_plus_negate.
+      * exact (y - z).
+      * by apply ideal_in_plus_negate.
+      * cbn.
         refine (_ @ ap011 (fun x y => x - y) p q).
         rewrite <- 2 rng_plus_assoc.
         f_ap.
         rewrite negate_sg_op.
         rewrite rng_plus_comm.
         rewrite rng_plus_assoc.
-        reflexivity. }
-  intro x.
-  strip_truncations.
-  intros r.
-  split;[intro; exact tt|].
-  intros _.
-  destruct x as [[[x xi] [y yj]] p].
-  rewrite <- rng_mult_one_r.
-  change (x + y = 1) in p.
-  rewrite <- p.
-  rewrite rng_dist_l.
-  apply tr.
-  rapply sgt_op'.
-  - apply sgt_in.
-    left.
-    by apply isideal.
-  - apply sgt_in.
-    right.
-    by apply isideal.
+        reflexivity.
+  - intro x.
+    strip_truncations.
+    intros r.
+    split;[intro; exact tt|].
+    intros _.
+    destruct x as [[[x xi] [y yj]] p].
+    rewrite <- rng_mult_one_r.
+    change (x + y = 1) in p.
+    rewrite <- p.
+    rewrite rng_dist_l.
+    apply tr.
+    rapply sgt_op'.
+    + apply sgt_in.
+      left.
+      by apply isleftideal.
+    + apply sgt_in.
+      right.
+      by apply isleftideal.
 Defined.
 
 (** *** Ideal notations *)
@@ -388,22 +795,22 @@ End Notation.
 
 Section IdealLemmas.
 
-  Context {R : CRing}.
+  Context {R : Ring}.
 
-  (** Subset relation is antisymmetric *)
-  Lemma ideal_subset_antisymm (I J : Ideal R) : I ⊆ J -> J ⊆ I -> I ↔ J.
+  (** Subset relation is antisymmetric. *)
+  Lemma ideal_subset_antisymm (I J : Subgroup R) : I ⊆ J -> J ⊆ I -> I ↔ J.
   Proof.
     intros p q x; split; by revert x.
   Defined.
 
-  (** The zero ideal is contained in all ideals *)
-  Lemma ideal_zero_subset I : ideal_zero R ⊆ I.
+  (** The zero ideal is contained in all ideals. *)
+  Lemma ideal_zero_subset (I : Subgroup R) : ideal_zero R ⊆ I.
   Proof.
     intros x p; rewrite p; apply ideal_in_zero.
   Defined.
 
-  (** The unit ideal contains all ideals *)
-  Lemma ideal_unit_subset I : I ⊆ ideal_unit R.
+  (** The unit ideal contains all ideals. *)
+  Lemma ideal_unit_subset (I : Subgroup R) : I ⊆ ideal_unit R.
   Proof.
     hnf; cbn; trivial.
   Defined.
@@ -452,8 +859,7 @@ Section IdealLemmas.
     strip_truncations.
     induction p as [r i | | r s p1 IHp1 p2 IHp2 ].
     + destruct i as [s t].
-      rewrite commutativity.
-      by apply isideal.
+      by rapply isrightideal.
     + rapply ideal_in_zero.
     + by rapply ideal_in_plus_negate.
   Defined.
@@ -465,7 +871,7 @@ Section IdealLemmas.
     strip_truncations.
     induction p as [r i | | r s p1 IHp1 p2 IHp2 ].
     + destruct i as [s t].
-      by apply isideal.
+      by apply isleftideal.
     + rapply ideal_in_zero.
     + by rapply ideal_in_plus_negate.
   Defined.
@@ -500,7 +906,10 @@ Section IdealLemmas.
 
   (** TODO: *)
   (** The product of ideals is an associative operation. *)
-  (* Lemma ideal_product_assoc (I J K : Ideal R) : I ⋅ (J ⋅ K) ↔ (I ⋅ J) ⋅ K. *)
+  (* Lemma ideal_product_assoc (I J K : Ideal R) : I ⋅ (J ⋅ K) ↔ (I ⋅ J) ⋅ K.
+  Proof.
+    intros r; split; apply Trunc_functor.
+  Abort. *)
 
   (** Products of ideals are subsets of their intersection. *)
   Lemma ideal_product_subset_intersection (I J : Ideal R) : I ⋅ J ⊆ I ∩ J.
@@ -510,7 +919,7 @@ Section IdealLemmas.
     + apply ideal_product_subset_r.
   Defined.
 
-  (** Sums of ideals are the smallest ideal containing the summand. *)
+  (** Sums of ideals are the smallest ideal containing the summands. *)
   Lemma ideal_sum_smallest (I J K : Ideal R) : I ⊆ K -> J ⊆ K -> (I + J) ⊆ K.
   Proof.
     intros p q.
@@ -528,7 +937,7 @@ Section IdealLemmas.
     rapply ideal_sum_subset_l.
   Defined.
 
-  (** Sums preserve inclusions in left summand. *)
+  (** Sums preserve inclusions in the left summand. *)
   Lemma ideal_sum_subset_pres_l (I J K : Ideal R) : I ⊆ J -> (I + K) ⊆ (J + K).
   Proof.
     intros p.
@@ -539,7 +948,7 @@ Section IdealLemmas.
     apply ideal_sum_subset_r.
   Defined.
 
-  (** Sums preserve inclusions in right summand. *)
+  (** Sums preserve inclusions in the right summand. *)
   Lemma ideal_sum_subset_pres_r (I J K : Ideal R) : I ⊆ J -> (K + I) ⊆ (K + J).
   Proof.
     intros p.
@@ -639,25 +1048,7 @@ Section IdealLemmas.
     apply ideal_sum_subset_l.
   Defined.
 
-  (** Ideal products are commutative. *)
-  (** This only holds because we are in a commutative ring. *)
-  Lemma ideal_product_comm (I J : Ideal R) : I ⋅ J ↔ J ⋅ I.
-  Proof.
-    (** WLOG we show one direction *)
-    assert (p : forall K L : Ideal R, K ⋅ L ⊆ L ⋅ K).
-    { clear I J; intros I J.
-      intros r p.
-      strip_truncations.
-      induction p as [r p | |].
-      2: apply ideal_in_zero.
-      2: by apply ideal_in_plus_negate.
-      destruct p as [s t p q].
-      rewrite rng_mult_comm.
-      by apply tr, sgt_in, ipn_in. }
-    apply ideal_subset_antisymm; apply p.
-  Defined.
-
-  (** Unit ideal is left multiplicative identity *)
+  (** Unit ideal is left multiplicative identity. *)
   Lemma ideal_product_unit_l I : ideal_unit R ⋅ I ↔ I.
   Proof.
     apply ideal_subset_antisymm.
@@ -667,7 +1058,7 @@ Section IdealLemmas.
     by apply tr, sgt_in, ipn_in.
   Defined.
 
-  (** Unit ideal is right multiplicative ideal. *)
+  (** Unit ideal is right multiplicative identity. *)
   Lemma ideal_product_unit_r I : I ⋅ ideal_unit R ↔ I.
   Proof.
     apply ideal_subset_antisymm.
@@ -698,7 +1089,6 @@ Section IdealLemmas.
   Defined.
 
   (** Product of intersection and sum is subset of sum of products *)
-  (** This is stated a bit more generally, like we would for a general ring .*)
   Lemma ideal_product_intersection_sum_subset (I J : Ideal R)
     : (I ∩ J) ⋅ (I + J) ⊆ (I ⋅ J + J ⋅ I).
   Proof.
@@ -715,181 +1105,117 @@ Section IdealLemmas.
     rapply ideal_sum_comm.
   Defined.
 
-  (** Product of intersection and sum is a subset of product *)
-  (** Note that this is a generalization of lcm * gcd = product *)
-  (** In a commutative ring we can simplify the right hand side of the previous lemma. *)
-  Lemma ideal_product_intersection_sum_subset' (I J : Ideal R)
-    : (I ∩ J) ⋅ (I + J) ⊆ I ⋅ J.
+  (** Ideals are subsets of their ideal quotients *)
+  Lemma ideal_quotient_subset (I J : Ideal R) : I ⊆ (I :: J).
   Proof.
-    etransitivity.
-    2: rapply ideal_sum_self.
-    etransitivity.
-    2: rapply ideal_sum_subset_pres_r.
-    2: rapply ideal_product_comm.
-    apply ideal_product_intersection_sum_subset.
+    intros x i; split; apply tr; intros r j; cbn.
+    - by rapply isrightideal.
+    - by rapply isleftideal.
   Defined.
 
-  (** If the sum of ideals is the whole ring then their intersection is a subset of their product. *)
-  Lemma ideal_intersection_subset_product (I J : Ideal R)
-    : ideal_unit R ⊆ (I + J) -> I ∩ J ⊆ I ⋅ J.
+  (** If J divides I then the ideal quotient of J by I is trivial. *)
+  Lemma ideal_quotient_trivial (I J : Ideal R)
+    : I ⊆ J -> J :: I ↔ ideal_unit R.
   Proof.
     intros p.
-    etransitivity.
-    { apply ideal_eq_subset.
-      symmetry.
-      apply ideal_product_unit_r. }
-    etransitivity.
-    { rapply ideal_product_subset_pres_r.
-      exact p. }
-    rapply ideal_product_intersection_sum_subset'.
+    apply ideal_subset_antisymm.
+    1: cbv; trivial.
+    intros r _; split; apply tr; intros x q; cbn.
+    - by apply isleftideal, p. 
+    - rapply isrightideal.
+      by apply p.
   Defined.
 
-  (** This can be combined into a sufficient (but not necessery) condition for equality of intersections and products. *)
-  Lemma ideal_intersection_is_product (I J : Ideal R)
-    : Coprime I J -> I ∩ J ↔ I ⋅ J.
+  (** The ideal quotient of I by unit is I. *)
+  Lemma ideal_quotient_unit_bottom (I : Ideal R)
+    : (I :: ideal_unit R) ↔ I.
   Proof.
-    intros p.
     apply ideal_subset_antisymm.
-    - apply ideal_intersection_subset_product.
-      unfold Coprime in p.
-      apply symmetry in p.
-      rapply p.
-    - apply ideal_product_subset_intersection.
-  Defined.
-
-  Section AssumeFunext.
-    Context `{Funext}.
-
-    (** Ideals are subsets of their ideal quotients *)
-    Lemma ideal_quotient_subset (I J : Ideal R) : I ⊆ (I :: J).
-    Proof.
-      intros x i r j.
-      rewrite rng_mult_comm.
-      by apply isideal.
-    Defined.
-
-    (** The ideal quotient is a right adjoint to the product in the monoidal lattice of ideals. *)
-    Lemma ideal_quotient_subset_prod (I J K : Ideal R)
-      : I ⋅ J ⊆ K <-> I ⊆ (K :: J).
-    Proof.
-      split.
-      { intros p r i s j.
-        by apply p, tr, sgt_in, ipn_in. }
-      intros p x q.
-      strip_truncations.
-      induction q as [r x | | ].
-      { destruct x.
-        cbv in p.
-        by apply p. }
-      1: apply ideal_in_zero.
-      by apply ideal_in_plus_negate.
-    Defined.
-
-    (** Ideal quotients partially cancel *)
-    Lemma ideal_quotient_product_left (I J : Ideal R)
-      : (I :: J) ⋅ J ⊆ I.
-    Proof.
-      by apply ideal_quotient_subset_prod.
-    Defined.
-
-    (** If J divides I then the ideal quotient of J by I is trivial. *)
-    Lemma ideal_quotient_trivial (I J : Ideal R)
-      : I ⊆ J -> J :: I ↔ ideal_unit R.
-    Proof.
-      intros p.
-      apply ideal_subset_antisymm.
-      1: cbv; trivial.
-      intros r _ x q.
-      by apply isideal, p.
-    Defined.
-
-    (** The ideal quotient of I by unit is I *)
-    Lemma ideal_quotient_unit_bottom (I : Ideal R)
-      : (I :: ideal_unit R) ↔ I.
-    Proof.
-      apply ideal_subset_antisymm.
-      { intros r p.
-        rewrite <- rng_mult_one_r.
-        exact (p cring_one tt). }
-      apply ideal_quotient_subset.
-    Defined.
-
-    (** The ideal quotient of unit by I is unit *)
-    Lemma ideal_quotient_unit_top (I : Ideal R)
-      : (ideal_unit R :: I) ↔ ideal_unit R.
-    Proof.
-      cbv; split; trivial.
-    Defined.
-
-    (** The ideal quotient by a sum is an intersection of ideal quotients *)
-    Lemma ideal_quotient_sum (I J K : Ideal R)
-      : (I :: (J + K)) ↔ (I :: J) ∩ (I :: K).
-    Proof.
-      apply ideal_subset_antisymm.
-      { intros r p; split.
-        + intros x j.
-          hnf in p; apply p.
-          by apply ideal_sum_subset_l.
-        + intros x k.
-          hnf in p; apply p.
-          by apply ideal_sum_subset_r. }
-      intros r [p q] x jk.
-      hnf in p, q.
+    - intros r [p q].
       strip_truncations.
-      induction jk as [s x | | ].
-      - destruct x.
-        1: by apply p.
-        by apply q.
-      - rewrite rng_mult_zero_r.
-        apply ideal_in_zero.
-      - rewrite rng_dist_l.
+      rewrite <- rng_mult_one_r.
+      exact (p ring_one tt).
+    - apply ideal_quotient_subset.
+  Defined.
+
+  (** The ideal quotient of unit by I is unit. *)
+  Lemma ideal_quotient_unit_top (I : Ideal R)
+    : (ideal_unit R :: I) ↔ ideal_unit R.
+  Proof.
+    split.
+    - cbn; trivial.
+    - intros ?; split; apply tr;
+      cbn; split; trivial. 
+  Defined.
+
+  (** The ideal quotient by a sum is an intersection of ideal quotients. *)
+  Lemma ideal_quotient_sum (I J K : Ideal R)
+    : (I :: (J + K)) ↔ (I :: J) ∩ (I :: K).
+  Proof.
+    apply ideal_subset_antisymm.
+    { intros r [p q]; strip_truncations; split; split; apply tr; intros x jk.
+      - by rapply p; rapply ideal_sum_subset_l.
+      - by rapply q; rapply ideal_sum_subset_l.
+      - by rapply p; rapply ideal_sum_subset_r.
+      - by rapply q; rapply ideal_sum_subset_r. }
+    intros r [[p q] [u v]]; strip_truncations; split; apply tr;
+    intros x jk; strip_truncations.
+    - induction jk as [? [] | | ? ? ? ? ? ? ].
+      + by apply p.
+      + by apply u.
+      + apply u, ideal_in_zero.
+      + rewrite rng_dist_l.
         rewrite rng_mult_negate_r.
         by apply ideal_in_plus_negate.
-    Defined.
+    - induction jk as [? [] | | ? ? ? ? ? ? ].
+      + by apply q.
+      + by apply v.
+      + apply v, ideal_in_zero.
+      + change (I ((g - h) * r)). 
+        rewrite rng_dist_r.
+        rewrite rng_mult_negate_l.
+        by apply ideal_in_plus_negate.
+  Defined.
 
-    Lemma ideal_quotient_product (I J K : Ideal R)
-      : (I :: J) :: K ↔ (I :: (J ⋅ K)).
-    Proof.
-      apply ideal_subset_antisymm.
-      { hnf. intros x p y q. cbv in p.
-        strip_truncations.
-        induction q as [y i | | ].
-        - destruct i as [ y z s t ].
-          rewrite (rng_mult_comm y).
-          rewrite rng_mult_assoc.
-          by apply p.
-        - rewrite rng_mult_zero_r.
-          apply ideal_in_zero.
-        - rewrite rng_dist_l.
-          rewrite rng_mult_negate_r.
-          by apply ideal_in_plus_negate. }
-      intros x p y k z j; hnf in p.
-      rewrite <- rng_mult_assoc.
-      rewrite (rng_mult_comm y).
-      by apply p, tr, sgt_in, ipn_in.
-    Defined.
-
-    (** Ideal quotients distribute over intersections *)
-    Lemma ideal_quotient_intersection (I J K : Ideal R)
-      : (I ∩ J :: K) ↔ (I :: K) ∩ (J :: K).
-    Proof.
-      apply ideal_subset_antisymm.
-      1: intros r p; hnf in p; split; hnf; intros; by apply p.
-      intros r [p q]; hnf in p, q; intros x k; by split; [apply p | apply q].
-    Defined.
-
-    (** Annihilators reverse the order of inclusion. *)
-    Lemma ideal_annihilator_subset (I J : Ideal R) : I ⊆ J -> Ann J ⊆ Ann I.
-    Proof.
-      intros p x q y i.
-      hnf in q.
-      by apply q, p.
-    Defined.
-
-  End AssumeFunext.
+  (** Ideal quotients distribute over intersections. *)
+  Lemma ideal_quotient_intersection (I J K : Ideal R)
+    : (I ∩ J :: K) ↔ (I :: K) ∩ (J :: K).
+  Proof.
+    apply ideal_subset_antisymm.
+    - intros r [p q]; strip_truncations; split; split; apply tr; intros x k.
+      1,3: by apply p.
+      1,2: by apply q.
+    - intros r [[p q] [u v]].
+      strip_truncations; split; apply tr; intros x k; split.
+      + by apply p.
+      + by apply u.
+      + by apply q.
+      + by apply v.
+  Defined.
 
-End IdealLemmas.
+  (** Annihilators reverse the order of inclusion. *)
+  Lemma ideal_annihilator_subset (I J : Ideal R) : I ⊆ J -> Ann J ⊆ Ann I.
+  Proof.
+    intros p x [q q']; hnf in q, q'; strip_truncations;
+      split; apply tr; intros y i.
+    - by apply q, p.
+    - by apply q', p.
+  Defined.
 
+  (** The annihilator of an ideal is equal to a quotient of zero. *)
+  Lemma ideal_annihilator_zero_quotient (I : Ideal R)
+    : Ann I ↔ ideal_zero R :: I.
+  Proof.
+    intros x; split.
+    - intros [p q]; strip_truncations; split; apply tr; intros y i.
+      + exact (p y i).
+      + exact (q y i).
+    - intros [p q]; strip_truncations; split; apply tr; intros y i.
+      + exact (p y i).
+      + exact (q y i).
+  Defined.
+  
+End IdealLemmas.
 
 (** TODO: Maximal ideals *)
 (** TODO: Principal ideal *)
diff --git a/theories/Algebra/Rings/KroneckerDelta.v b/theories/Algebra/Rings/KroneckerDelta.v
new file mode 100644
index 00000000000..0a8dd7154bf
--- /dev/null
+++ b/theories/Algebra/Rings/KroneckerDelta.v
@@ -0,0 +1,154 @@
+Require Import Basics.Overture Basics.Decidable Spaces.Nat.
+Require Import Algebra.Rings.Ring.
+Require Import Classes.interfaces.abstract_algebra.
+
+Local Set Universe Minimization ToSet.
+Local Set Polymorphic Inductive Cumulativity.
+
+(** ** Kronecker Delta *)
+
+Section AssumeDecidable.
+  (** Throughout this section, we assume that we have a type [A] with decidable equality. This will be our indexing type and can be thought of as [nat] for reading purposes. *)
+
+  Universes u v.
+  Context {A : Type@{u}} `{DecidablePaths@{u} A} {R : Ring@{v}}.
+
+  (** The Kronecker delta function is a function of elements of [A] that is 1 when the two numbers are equal and 0 otherwise. It is useful for working with finite sums of ring elements. *)
+  Definition kronecker_delta@{} (i j : A) : R
+    := if dec (i = j) then 1 else 0.
+
+  (** Kronecker delta with the same index is 1. *)
+  Definition kronecker_delta_refl@{} (i : A)
+    : kronecker_delta i i = 1.
+  Proof.
+    unfold kronecker_delta.
+    generalize (dec (i = i)).
+    by rapply decidable_paths_refl.
+  Defined.
+
+  (** Kronecker delta with differing indices is 0. *)
+  Definition kronecker_delta_neq@{} {i j : A} (p : i <> j)
+    : kronecker_delta i j = 0.
+  Proof.
+    unfold kronecker_delta.
+    by decidable_false (dec (i = j)) p.
+  Defined.
+
+  (** Kronecker delta is symmetric in its arguments. *)
+  Definition kronecker_delta_symm@{} (i j : A)
+    : kronecker_delta i j = kronecker_delta j i.
+  Proof.
+    unfold kronecker_delta.
+    destruct (dec (i = j)) as [p|q].
+    - by decidable_true (dec (j = i)) p^.
+    - by decidable_false (dec (j = i)) (symmetric_neq q).
+  Defined.
+
+  (** An injective endofunction on [A] preserves the Kronecker delta. *)
+  Definition kronecker_delta_map_inj@{} (i j : A) (f : A -> A)
+    `{!IsInjective f}
+    : kronecker_delta (f i) (f j) = kronecker_delta i j.
+  Proof.
+    unfold kronecker_delta.
+    destruct (dec (i = j)) as [p|p].
+    - by decidable_true (dec (f i = f j)) (ap f p).
+    - destruct (dec (f i = f j)) as [q|q].
+      + apply (injective f) in q.
+        contradiction.
+      + reflexivity.
+  Defined.
+
+  (** Kronecker delta commutes with any ring element. *)
+  Definition kronecker_delta_comm@{} (i j : A) (r : R)
+    : r * kronecker_delta i j = kronecker_delta i j * r.
+  Proof.
+    unfold kronecker_delta.
+    destruct (dec (i = j)).
+    - exact (rng_mult_one_r _ @ (rng_mult_one_l _)^).
+    - exact (rng_mult_zero_r _ @ (rng_mult_zero_l _)^).
+  Defined.
+    
+End AssumeDecidable.
+
+(** The following lemmas are specialised to when the indexing type is [nat]. *)
+
+(** Kronecker delta where the first index is strictly less than the second is 0. *)
+Definition kronecker_delta_lt {R : Ring} {i j : nat} (p : (i < j)%nat)
+  : kronecker_delta (R:=R) i j = 0.
+Proof.
+  apply kronecker_delta_neq.
+  intros q; destruct q.
+  by apply lt_irrefl in p.
+Defined.
+
+(** Kronecker delta where the first index is strictly greater than the second is 0. *)
+Definition kronecker_delta_gt {R : Ring} {i j : nat} (p : (j < i)%nat)
+  : kronecker_delta (R:=R) i j = 0.
+Proof.
+  apply kronecker_delta_neq.
+  intros q; destruct q.
+  by apply lt_irrefl in p.
+Defined.
+
+(** Kronecker delta can be used to extract a single term from a finite sum. *)
+Definition rng_sum_kronecker_delta_l {R : Ring} (n i : nat) (Hi : (i < n)%nat)
+  (f : forall k, (k < n)%nat -> R)
+  : ab_sum n (fun j Hj => kronecker_delta i j * f j Hj) = f i Hi.
+Proof.
+  revert i Hi f; simple_induction n n IHn; intros i Hi f.
+  1: destruct (not_lt_zero_r _ Hi).
+  destruct (dec (i = n)) as [p|p].
+  - destruct p; simpl.
+    rewrite kronecker_delta_refl.
+    rewrite rng_mult_one_l.
+    rewrite <- rng_plus_zero_r.
+    apply ap11.
+    { apply (ap (fun h => plus (f i h))), path_ishprop. }
+    nrapply ab_sum_zero.
+    intros k Hk.
+    rewrite (kronecker_delta_gt Hk).
+    apply rng_mult_zero_l.
+  - simpl; lhs nrapply ap.
+    + nrapply IHn.
+      apply neq_iff_lt_or_gt in p.
+      destruct p; [assumption|].
+      apply gt_iff_not_leq in Hi.
+      contradiction Hi.
+    + rewrite (kronecker_delta_neq p).
+      rewrite rng_mult_zero_l.
+      rewrite grp_unit_l.
+      apply ap, path_ishprop.
+Defined.
+
+(** Variant of [rng_sum_kronecker_delta_l] where the indexing is swapped. *)
+Definition rng_sum_kronecker_delta_l' {R : Ring} (n i : nat) (Hi : (i < n)%nat)
+  (f : forall k, (k < n)%nat -> R)
+  : ab_sum n (fun j Hj => kronecker_delta j i * f j Hj) = f i Hi.
+Proof.
+  lhs nrapply path_ab_sum.
+  2: nrapply rng_sum_kronecker_delta_l.
+  intros k Hk.
+  cbn; f_ap; apply kronecker_delta_symm.
+Defined.
+
+(** Variant of [rng_sum_kronecker_delta_l] where the Kronecker delta appears on the right. *)
+Definition rng_sum_kronecker_delta_r {R : Ring} (n i : nat) (Hi : (i < n)%nat)
+  (f : forall k, (k < n)%nat -> R)
+  : ab_sum n (fun j Hj => f j Hj * kronecker_delta i j) = f i Hi.
+Proof.
+  lhs nrapply path_ab_sum.
+  2: nrapply rng_sum_kronecker_delta_l.
+  intros k Hk.
+  apply kronecker_delta_comm.
+Defined.
+
+(** Variant of [rng_sum_kronecker_delta_r] where the indexing is swapped. *)
+Definition rng_sum_kronecker_delta_r' {R : Ring} (n i : nat) (Hi : (i < n)%nat)
+  (f : forall k, (k < n)%nat -> R)
+  : ab_sum n (fun j Hj => f j Hj * kronecker_delta j i) = f i Hi.
+Proof.
+  lhs nrapply path_ab_sum.
+  2: nrapply rng_sum_kronecker_delta_l'.
+  intros k Hk.
+  apply kronecker_delta_comm.
+Defined.
diff --git a/theories/Algebra/Rings/Localization.v b/theories/Algebra/Rings/Localization.v
new file mode 100644
index 00000000000..2e5197ca3a7
--- /dev/null
+++ b/theories/Algebra/Rings/Localization.v
@@ -0,0 +1,545 @@
+Require Import Basics.Overture Basics.Trunc Basics.Tactics Colimits.Quotient
+  abstract_algebra Rings.CRing Truncations.Core Nat.Core
+  Rings.QuotientRing WildCat.Core WildCat.Equiv.
+
+Local Open Scope mc_scope.
+
+(** * Localization of commutative rings *)
+
+(** Localization is a way to make elements in a commutative ring invertible by adding inverses, in the most minimal way possible. It generalizes the familiar operation of a field of fractions. *)
+
+(** ** Multiplicative subsets *)
+
+(** A multiplicative subset is formally a submonoid of the multiplicative monoid of a ring. Essentially it is a subset closed under finite products. *)
+
+(** *** Definition *)
+
+(** Multiplicative subsets of a ring [R] consist of: *)
+Class IsMultiplicativeSubset {R : CRing} (S : R -> Type) : Type := {
+  (** Contains one *)
+  mss_one : S 1 ;
+  (** Closed under multiplication *)
+  mss_mult : forall x y, S x -> S y -> S (x * y) ;
+}.
+
+Arguments mss_one {R _ _}.
+Arguments mss_mult {R _ _ _ _}.
+
+(** *** Examples *)
+
+(** The multiplicative subset of powers of a ring element. *)
+Global Instance ismultiplicative_powers (R : CRing) (x : R)
+  : IsMultiplicativeSubset (fun r => exists n, rng_power x n = r).
+Proof.
+  srapply Build_IsMultiplicativeSubset; cbn beta.
+  1: by exists 0%nat.
+  intros a b np mq.
+  destruct np as [n p], mq as [m q].
+  exists (n + m)%nat.
+  lhs_V nrapply rng_power_mult_law.
+  f_ap.
+Defined.
+
+(** Invertible elements of a ring form a multiplicative subset. *)
+Global Instance ismultiplicative_isinvertible (R : CRing)
+  : IsMultiplicativeSubset (@IsInvertible R) := {}.
+
+(** TODO: Property of being a localization. *)
+
+(** ** Construction of localization *)
+
+Section Localization.
+
+  (** We now construct the localization of a ring at a multiplicative subset as the following HIT:
+
+  <<<
+  HIT (Quotient fraction_eq) (R : CRing) (S : R -> Type)
+    `{IsMultiplicativeSubset R} :=
+  | loc_frac (n d : R) (p : S d) : Localization R S
+  | loc_frac_eq (n1 d1 n2 d2 : R) (p1 : S d1) (p2 : S d2)
+      (x : R) (q : S x) (r : x * (d2 * n1 - n2 * d1) = 0)
+      : loc_frac n1 d1 p1 = loc_frac n2 d2 p2
+  .
+  >>>
+  along with the condition that this HIT be a set.
+
+  We will implement this HIT by writing it as a set quotient. From now onwards, [loc_frac] will be implemented as [class_of fraction_eq] and [loc_frac_eq] will be implemented as [qglue]. *)
+
+  Context (R : CRing) (S : R -> Type) `{!IsMultiplicativeSubset S}.
+
+  (** *** Construction of underlying Localization type *)
+
+  (** The base type will be the type of fractions with respect to a multiplicative subset. This consists of pairs of elements of a ring [R] where the [denominator] is in the multiplicative subset [S]. *)
+  Record Fraction := {
+    numerator : R ;
+    denominator : R ;
+    in_mult_subset_denominator : S denominator ;
+  }.
+
+  (** We consider two fractions to be equal if we can rearrange the fractions as products and ask for equality upto some scaling factor from the multiplicative subset [S]. *)
+  Definition fraction_eq : Relation Fraction.
+  Proof.
+    intros [n1 d1 ?] [n2 d2 ?].
+    refine (exists (x : R), S x /\ _).
+    exact (x * n1 * d2 = x * n2 * d1).
+  Defined.
+
+  (** It is convenient to produce elements of this relation specalized to when the scaling factor is [1]. *)
+  Definition fraction_eq_simple f1 f2
+    (p : numerator f1 * denominator f2 = numerator f2 * denominator f1)
+    : fraction_eq f1 f2.
+  Proof.
+    exists 1.
+    refine (mss_one, _).
+    lhs_V nrapply rng_mult_assoc.
+    rhs_V nrapply rng_mult_assoc.
+    exact (ap (1 *.) p).
+  Defined.
+
+  (** Fraction equality is a reflexive relation. *)
+  Definition fraction_eq_refl f1 : fraction_eq f1 f1.
+  Proof.
+    apply fraction_eq_simple.
+    reflexivity.
+  Defined.
+
+  (** Elements of [R] can be considered fractions. *)
+  Definition frac_in : R -> Fraction
+    := fun r => Build_Fraction r 1 mss_one.
+
+  (** Now that we have defined the HIT as above, we can define the ring structure. *)
+
+  (** *** Addition operation *)
+
+  (** Fraction addition is the usual addition of fractions. *)
+  Definition frac_add : Fraction -> Fraction -> Fraction :=
+    fun '(Build_Fraction n1 d1 p1) '(Build_Fraction n2 d2 p2)
+      => Build_Fraction (n1 * d2 + n2 * d1) (d1 * d2) (mss_mult p1 p2).
+
+  (** Fraction addition is well-defined upto equality of fractions. *)
+
+  (** It is easier to prove well-definedness as a function of both arguments at once. *)
+  Definition frac_add_wd (f1 f1' f2 f2' : Fraction)
+    (p : fraction_eq f1 f1') (q : fraction_eq f2 f2')
+    : fraction_eq (frac_add f1 f2) (frac_add f1' f2').
+  Proof.
+    destruct f1 as [a s ss], f1' as [a' s' ss'],
+      f2 as [b t st], f2' as [b' t' st'],
+      p as [x [sx p]], q as [y [sy q]].
+    refine (x * y ; (mss_mult sx sy, _)).
+    simpl.
+    rewrite 2 rng_dist_l, 2 rng_dist_r.
+    snrapply (ap011 (+)). 
+    - rewrite 4 rng_mult_assoc.
+      rewrite 8 (rng_mult_permute_2_3 _ y).
+      apply (ap (.* y)).
+      rewrite 2 (rng_mult_permute_2_3 _ t).
+      apply (ap (.* t)).
+      rewrite (rng_mult_permute_2_3 _ t').
+      f_ap.
+    - do 2 lhs_V nrapply rng_mult_assoc.
+      do 2 rhs_V nrapply rng_mult_assoc.
+      f_ap.
+      rewrite 6 rng_mult_assoc.
+      rewrite 2 (rng_mult_permute_2_3 _ _ t').
+      rewrite 2 (rng_mult_permute_2_3 _ _ t).
+      lhs_V nrapply rng_mult_assoc.
+      rhs_V nrapply rng_mult_assoc.
+      f_ap; apply rng_mult_comm.
+  Defined.
+
+  Definition frac_add_wd_l (f1 f1' f2 : Fraction) (p : fraction_eq f1 f1')
+    : fraction_eq (frac_add f1 f2) (frac_add f1' f2).
+  Proof.
+    pose (fraction_eq_refl f2).
+    by apply frac_add_wd.
+  Defined.
+
+  Definition frac_add_wd_r (f1 f2 f2' : Fraction) (p : fraction_eq f2 f2')
+    : fraction_eq (frac_add f1 f2) (frac_add f1 f2').
+  Proof.
+    pose (fraction_eq_refl f1).
+    by apply frac_add_wd.
+  Defined.
+
+  (** The addition operation on the localization is induced from the addition operation for fractions. *)
+  Instance plus_rng_localization : Plus (Quotient fraction_eq).
+  Proof.
+    srapply Quotient_rec2.
+    - rapply fraction_eq_refl.
+    - cbn.
+      intros f1 f2.
+      exact (class_of _ (frac_add f1 f2)).
+    - cbn beta.
+      intros f1 f1' p f2 f2' q.
+      by apply qglue, frac_add_wd.
+  Defined.
+
+  (** *** Multiplication operation *)
+
+  Definition frac_mult : Fraction -> Fraction -> Fraction :=
+    fun '(Build_Fraction n1 d1 p1) '(Build_Fraction n2 d2 p2)
+      => Build_Fraction (n1 * n2) (d1 * d2) (mss_mult p1 p2).
+
+  Definition frac_mult_wd_l f1 f1' f2 (p : fraction_eq f1 f1')
+    : fraction_eq (frac_mult f1 f2) (frac_mult f1' f2).
+  Proof.
+    destruct p as [x [s p]].
+    refine (x; (s, _)); simpl.
+    rewrite 4 rng_mult_assoc.
+    rewrite (rng_mult_permute_2_3 _ _ (denominator f1')).
+    rewrite (rng_mult_permute_2_3 _ _ (denominator f1)).
+    lhs_V nrapply rng_mult_assoc.
+    rhs_V nrapply rng_mult_assoc.
+    f_ap.
+  Defined.
+
+  Definition frac_mult_wd_r f1 f2 f2' (p : fraction_eq f2 f2')
+    : fraction_eq (frac_mult f1 f2) (frac_mult f1 f2').
+  Proof.
+    destruct p as [x [s p]].
+    refine (x; (s, _)); simpl.
+    rewrite 4 rng_mult_assoc.
+    rewrite (rng_mult_permute_2_3 _ _ (numerator f2)).
+    rewrite 2 (rng_mult_permute_2_3 _ _ (denominator f2')).
+    rewrite (rng_mult_permute_2_3 _ _ (numerator f2')).
+    rewrite 2 (rng_mult_permute_2_3 _ _ (denominator f2)).
+    lhs_V nrapply rng_mult_assoc.
+    rhs_V nrapply rng_mult_assoc.
+    f_ap.
+  Defined.
+
+  Instance mult_rng_localization: Mult (Quotient fraction_eq).
+  Proof.
+    srapply Quotient_rec2.
+    - rapply fraction_eq_refl.
+    - cbn.
+      intros f1 f2.
+      exact (class_of _ (frac_mult f1 f2)).
+    - cbn beta.
+      intros f1 f1' p f2 f2' q.
+      transitivity (class_of fraction_eq (frac_mult f1' f2)).
+      + by apply qglue, frac_mult_wd_l.
+      + by apply qglue, frac_mult_wd_r.
+  Defined.
+
+  (** *** Zero element *)
+
+  Instance zero_rng_localization : Zero (Quotient fraction_eq)
+    := class_of _ (Build_Fraction 0 1 mss_one).
+
+  (** *** One element *)
+
+  Instance one_rng_localization : One (Quotient fraction_eq)
+    := class_of _(Build_Fraction 1 1 mss_one).
+
+  (** *** Negation operation *)
+
+  Definition frac_negate : Fraction -> Fraction
+    :=  fun '(Build_Fraction n d p) => Build_Fraction (- n) d p.
+
+  Definition frac_negate_wd f1 f2 (p : fraction_eq f1 f2)
+    : fraction_eq (frac_negate f1) (frac_negate f2).
+  Proof.
+    destruct p as [x [s p]].
+    refine (x; (s,_)); simpl.
+    rewrite 2 rng_mult_negate_r, 2 rng_mult_negate_l.
+    f_ap.
+  Defined.
+
+  Instance negate_rng_localization : Negate (Quotient fraction_eq).
+  Proof.
+    srapply Quotient_rec.
+    - intros f.
+      apply class_of.
+      exact (frac_negate f).
+    - intros f1 f2 p.
+      by apply qglue, frac_negate_wd.
+  Defined.
+
+  (** *** Ring laws *)
+  
+  (** Commutativity of addition *)
+  Instance commutative_plus_rng_localization
+    : Commutative plus_rng_localization.
+  Proof.
+    srapply Quotient_ind2_hprop; intros x y.
+    apply qglue, fraction_eq_simple; simpl.
+    rewrite (rng_mult_comm (denominator y) (denominator x)).
+    f_ap; apply rng_plus_comm.
+  Defined.
+
+  (** Left additive identity *)
+  Instance leftidentity_plus_rng_localization
+    : LeftIdentity plus_rng_localization zero_rng_localization.
+  Proof.
+    srapply Quotient_ind_hprop; intros f.
+    apply qglue, fraction_eq_simple; simpl.
+    f_ap.
+    - rewrite rng_mult_zero_l.
+      rewrite rng_plus_zero_l.
+      apply rng_mult_one_r.
+    - symmetry.
+      apply rng_mult_one_l.
+  Defined.
+
+  Instance leftinverse_plus_rng_localization
+    : LeftInverse plus_rng_localization negate_rng_localization zero_rng_localization.
+  Proof.
+    srapply Quotient_ind_hprop; intros f.
+    apply qglue, fraction_eq_simple; simpl.
+    refine (rng_mult_one_r _ @ _).
+    refine (_ @ (rng_mult_zero_l _)^).
+    rewrite rng_mult_negate_l.
+    apply rng_plus_negate_l.
+  Defined.
+
+  Instance associative_plus_rng_localization
+    : Associative plus_rng_localization.
+  Proof.
+    srapply Quotient_ind3_hprop; intros x y z.
+    apply qglue, fraction_eq_simple.
+    simpl.
+    rewrite ? rng_dist_r.
+    rewrite ? rng_mult_assoc.
+    rewrite ? rng_plus_assoc.
+    do 4 f_ap.
+    all: rewrite <- ? rng_mult_assoc.
+    all: f_ap.
+    2: apply rng_mult_comm.
+    rewrite rng_mult_assoc.
+    apply rng_mult_comm.
+  Defined.
+
+  Instance leftidentity_mult_rng_localization
+    : LeftIdentity mult_rng_localization one_rng_localization.
+  Proof.
+    srapply Quotient_ind_hprop; intros f.
+    apply qglue, fraction_eq_simple; simpl.
+    f_ap; [|symmetry]; apply rng_mult_one_l.
+  Defined.
+
+  Instance associative_mult_rng_localization
+    : Associative mult_rng_localization.
+  Proof.
+    srapply Quotient_ind3_hprop; intros x y z.
+    apply qglue, fraction_eq_simple.
+    f_ap; [|symmetry]; apply rng_mult_assoc.
+  Defined.
+
+  Instance commutative_mult_rng_localization
+    : Commutative mult_rng_localization.
+  Proof.
+    srapply Quotient_ind2_hprop; intros x y.
+    apply qglue, fraction_eq_simple; simpl.
+    f_ap; rapply rng_mult_comm.
+  Defined.
+
+  Instance leftdistribute_rng_localization
+    : LeftDistribute mult_rng_localization plus_rng_localization.
+  Proof.
+    srapply Quotient_ind3_hprop; intros x y z.
+    apply qglue, fraction_eq_simple.
+    simpl.
+    rewrite ? rng_dist_l, ? rng_dist_r.
+    rewrite ? rng_mult_assoc.
+    do 2 f_ap.
+    all: rewrite <- ? rng_mult_assoc.
+    all: do 2 f_ap.
+    all: rewrite ? rng_mult_assoc.
+    all: rewrite (rng_mult_comm (_ x)).
+    all: rewrite <- ? rng_mult_assoc.
+    all: f_ap.
+    all: rewrite (rng_mult_comm _ (_ y)).
+    all: rewrite <- ? rng_mult_assoc.
+    all: f_ap.
+  Defined.
+
+  Definition rng_localization : CRing.
+  Proof.
+    snrapply Build_CRing'.
+    1: rapply (Build_AbGroup' (Quotient fraction_eq)).
+    all: exact _.
+  Defined.
+
+  Definition loc_in : R $-> rng_localization.
+  Proof.
+    snrapply Build_RingHomomorphism.
+    1: exact (class_of _ o frac_in).
+    snrapply Build_IsSemiRingPreserving.
+    - snrapply Build_IsMonoidPreserving.
+      + intros x y.
+        snrapply qglue.
+        apply fraction_eq_simple.
+        by simpl; rewrite 5 rng_mult_one_r.
+      + reflexivity.
+    - snrapply Build_IsMonoidPreserving.
+      + intros x y.
+        snrapply qglue.
+        apply fraction_eq_simple.
+        by simpl; rewrite 3 rng_mult_one_r.
+      + reflexivity.
+  Defined.
+  
+  Section Rec.
+
+    Context (T : CRing) (f : R $-> T)
+      (H : forall x, S x -> IsInvertible T (f x)).
+
+    Definition rng_localization_rec_map : rng_localization -> T.
+    Proof.
+      srapply Quotient_rec.
+      - intros [n d sd].
+        refine (f n * inverse_elem (f d)).
+        exact (H d sd).
+      - simpl.
+        intros x y z.
+        apply rng_inv_moveR_rV.
+        rhs_V nrapply rng_mult_move_left_assoc.
+        rhs_V nrapply rng_mult_assoc.
+        apply rng_inv_moveL_Vr.
+        lhs_V nrapply rng_homo_mult.
+        rhs_V nrapply rng_homo_mult.
+        nrapply (equiv_inj (f z.1 *.)).
+        { nrapply isequiv_rng_inv_mult_l.
+          exact (H _ (fst z.2)). }
+        lhs_V nrapply rng_homo_mult.
+        rhs_V nrapply rng_homo_mult.
+        lhs nrapply ap.
+        1: lhs nrapply rng_mult_assoc.
+        1: nrapply rng_mult_permute_2_3.
+        rhs nrapply ap.
+        2: nrapply rng_mult_assoc.
+        exact (ap f (snd z.2)).
+    Defined.
+
+    Instance issemiringpreserving_rng_localization_rec_map
+      : IsSemiRingPreserving rng_localization_rec_map.
+    Proof.
+      snrapply Build_IsSemiRingPreserving.
+      - snrapply Build_IsMonoidPreserving.
+        + srapply Quotient_ind2_hprop.
+          intros x y; simpl.
+          apply rng_inv_moveR_rV.
+          rhs nrapply rng_dist_r.
+          rewrite rng_homo_plus.
+          rewrite 3 rng_homo_mult.
+          f_ap.
+          1,2: rhs_V nrapply rng_mult_assoc.
+          1,2: f_ap.
+          1,2: lhs_V nrapply rng_mult_one_l.
+          1,2: rhs nrapply rng_mult_assoc.
+          2: rhs nrapply rng_mult_comm.
+          2: rhs nrapply rng_mult_assoc.
+          1,2: f_ap.
+          1,2: symmetry.
+          * apply rng_inv_l.
+          * apply rng_inv_r. 
+        + hnf; simpl. rewrite rng_homo_zero.
+          nrapply rng_mult_zero_l.
+      - snrapply Build_IsMonoidPreserving.
+        + srapply Quotient_ind2_hprop.
+          intros x y; simpl.
+          apply rng_inv_moveR_rV.
+          lhs nrapply rng_homo_mult.
+          rhs_V nrapply rng_mult_assoc.
+          rhs_V nrapply rng_mult_assoc.
+          apply ap.
+          apply rng_inv_moveL_Vr.
+          lhs nrapply rng_mult_comm.
+          rhs_V nrapply rng_mult_assoc.
+          apply ap.
+          apply rng_inv_moveL_Vr.
+          symmetry.
+          rhs nrapply rng_mult_comm.
+          nrapply rng_homo_mult.
+        + apply rng_inv_moveR_rV; symmetry.
+          apply rng_mult_one_l.
+    Defined.
+
+    Definition rng_localization_rec : rng_localization $-> T
+      := Build_RingHomomorphism rng_localization_rec_map _.
+    
+    Definition rng_localization_rec_beta
+      : rng_localization_rec $o loc_in $== f.
+    Proof.
+      intros x; simpl.   
+      apply rng_inv_moveR_rV.
+      lhs_V nrapply rng_mult_one_r.
+      nrapply ap; symmetry.
+      apply rng_homo_one.
+    Defined.
+  
+  End Rec.
+  
+  (** Elements belonging to the multiplicative subset [S] of [R] become invertible in [rng_localization R S]. *)
+  Global Instance isinvertible_rng_localization (x : R) (Sx : S x)
+    : IsInvertible rng_localization (loc_in x).
+  Proof.
+    snrapply isinvertible_cring.
+    - exact (class_of _ (Build_Fraction 1 x Sx)).
+    - apply qglue, fraction_eq_simple.
+      exact (rng_mult_assoc _ _ _)^.
+  Defined.
+  
+  (** As a special case, any denominator of a fraction must necessarily be invertible. *)
+  Global Instance isinvertible_denominator (f : Fraction)
+    : IsInvertible rng_localization (loc_in (denominator f)).
+  Proof.
+    snrapply isinvertible_rng_localization.
+    exact (in_mult_subset_denominator f).
+  Defined.
+  
+  (** Elements that were invertible in the original ring [R], continue to be invertible in [rng_localization R S]. Since [loc_in] is a ring homomorphism this is automatic. *)
+  Definition isinvertible_rng_localization_preserved (x : R)
+    : IsInvertible R x -> IsInvertible rng_localization (loc_in x)
+    := _.
+  
+  (** We can factor any fraction as the multiplication of the numerator and the inverse of the denominator. *)
+  Definition fraction_decompose (f : Fraction)
+    : class_of fraction_eq f
+      = loc_in (numerator f) * inverse_elem (loc_in (denominator f)).
+  Proof.
+    apply qglue, fraction_eq_simple.
+    nrapply rng_mult_assoc.
+  Defined.
+
+  Definition rng_localization_ind
+    (P : rng_localization -> Type)
+    (H : forall x, IsHProp (P x))
+    (Hin : forall x, P (loc_in x))
+    (Hinv : forall x (H : IsInvertible rng_localization x),
+      P x -> P (inverse_elem x))
+    (Hmul : forall x y, P x -> P y -> P (x * y))
+    : forall x, P x.
+  Proof.
+    srapply Quotient_ind.
+    - intros f.
+      refine (transport P (fraction_decompose f)^ _).
+      apply Hmul.
+      + apply Hin.
+      + apply Hinv, Hin.
+    - intros f1 f2 p.
+      apply path_ishprop.
+  Defined.
+  
+  Definition rng_localization_ind_homotopy {T : CRing}
+    {f g : rng_localization $-> T}
+    (p : f $o loc_in $== g $o loc_in)
+    : f $== g.
+  Proof.
+    srapply rng_localization_ind.
+    - exact p.
+    - hnf; intros x H q.
+      change (inverse_elem (f x) = inverse_elem (g x)).
+      apply isinvertible_unique.
+      exact q.
+    - hnf; intros x y q r.
+      lhs nrapply rng_homo_mult.
+      rhs nrapply rng_homo_mult.
+      f_ap.
+  Defined.
+
+End Localization.
+
+(** TODO: Show construction is a localization. *)
diff --git a/theories/Algebra/Rings/Matrix.v b/theories/Algebra/Rings/Matrix.v
new file mode 100644
index 00000000000..422e24e15ef
--- /dev/null
+++ b/theories/Algebra/Rings/Matrix.v
@@ -0,0 +1,1051 @@
+Require Import Basics.Overture Basics.Trunc Basics.Tactics Basics.Decidable.
+Require Import Types.Sigma.
+Require Import Spaces.List.Core Spaces.List.Theory Spaces.List.Paths.
+Require Import Algebra.Rings.Ring Algebra.Rings.Module Algebra.Rings.CRing
+  Algebra.Rings.KroneckerDelta Algebra.Rings.Vector.
+Require Import abstract_algebra.
+Require Import WildCat.Core WildCat.Paths.
+
+Set Universe Minimization ToSet.
+
+Local Open Scope mc_scope.
+
+(** * Matrices *)
+
+(** ** Definition *)
+
+Definition Matrix@{i} (R : Type@{i}) (m n : nat) : Type@{i}
+  := Vector (Vector R n) m.
+
+Global Instance istrunc_matrix (R : Type) k `{IsTrunc k.+2 R} m n
+  : IsTrunc k.+2 (Matrix R m n)
+  := _.
+
+(** Building a matrix from a function that takes row and column indices. *)
+Definition Build_Matrix (R : Type) (m n : nat)
+  (M_fun : forall (i : nat) (j : nat), (i < m)%nat -> (j < n)%nat -> R)
+  : Matrix R m n.
+Proof.
+  snrapply Build_Vector.
+  intros i Hi.
+  snrapply Build_Vector.
+  intros j Hj.
+  exact (M_fun i j Hi Hj).
+Defined.
+
+(** The length conditions here are decidable so can be inferred in proofs. *)
+Definition Build_Matrix' (R : Type) (m n : nat)
+  (l : list (list R))
+  (wf_row : length l = m)
+  (wf_col : for_all (fun row => length row = n) l)
+  : Matrix R m n.
+Proof.
+  snrefine (_; _).
+  - snrapply list_sigma.
+    + exact l.
+    + exact wf_col.
+  - by lhs nrapply length_list_sigma.
+Defined.
+
+Definition entries@{i|} {R : Type@{i}} {m n} (M : Matrix R m n)
+  : list (list R)
+  := list_map@{i i} pr1 (pr1 M).
+
+(** The entry at row [i] and column [j] of a matrix [M]. *)
+Definition entry {R : Type} {m n} (M : Matrix R m n) (i j : nat)
+  {H1 : (i < m)%nat} {H2 : (j < n)%nat}
+  : R
+  := Vector.entry (Vector.entry M i) j.
+
+(** Mapping a function on all the entries of a matrix. *)
+Definition matrix_map {R S : Type} {m n} (f : R -> S)
+  : Matrix R m n -> Matrix S m n
+  := fun M => Build_Matrix S m n (fun i j _ _ => f (entry M i j)).
+
+Definition matrix_map2 {R S T : Type} {m n} (f : R -> S -> T)
+  : Matrix R m n -> Matrix S m n -> Matrix T m n
+  := fun M N => Build_Matrix T m n
+    (fun i j _ _ => f (entry M i j) (entry N i j)).
+
+(** The [(i, j)]-entry of [Build_Matrix R m n M_fun] is [M_fun i j]. *)
+Definition entry_Build_Matrix {R : Type} {m n}
+  (M_fun : forall i j, (i < m)%nat -> (j < n)%nat -> R)
+  (i j : nat) (H1 : (i < m)%nat) (H2 : (j < n)%nat)
+  : entry (Build_Matrix R m n M_fun) i j = M_fun i j _ _.
+Proof.
+  unfold entry.
+  by rewrite 2 entry_Build_Vector.
+Defined.
+
+(** Two matrices are equal if all their entries are equal. *)
+Definition path_matrix {R : Type} {m n} (M N : Matrix R m n)
+  (H : forall i j (Hi : (i < m)%nat) (Hj : (j < n)%nat), entry M i j = entry N i j)
+  : M = N.
+Proof.
+  snrapply path_vector.
+  intros i Hi.
+  snrapply path_vector.
+  intros j Hj.
+  exact (H i j Hi Hj).
+Defined.
+
+(** ** Addition and module structure *)
+
+(** Here we define the abelian group of (n x m)-matrices over a ring. This follows from the abelian group structure of the underlying vectors. We are also able to derive a left module strucutre when the entries come from a left module. *)
+
+Definition abgroup_matrix (A : AbGroup) (m n : nat) : AbGroup
+  := abgroup_vector (abgroup_vector A n) m.
+
+Definition matrix_plus {A : AbGroup} {m n}
+  : Matrix A m n -> Matrix A m n -> Matrix A m n
+  := @sg_op (abgroup_matrix A m n) _.
+
+Definition matrix_zero (A : AbGroup) m n : Matrix A m n
+  := @mon_unit (abgroup_matrix A m n) _.
+
+Definition matrix_negate {A : AbGroup} {m n}
+  : Matrix A m n -> Matrix A m n
+  := @negate (abgroup_matrix A m n) _.
+
+Global Instance isleftmodule_isleftmodule_matrix (A : AbGroup) (m n : nat)
+  {R : Ring} `{IsLeftModule R A}
+  : IsLeftModule R (abgroup_matrix A m n).
+Proof.
+  snrapply isleftmodule_isleftmodule_vector.
+  snrapply isleftmodule_isleftmodule_vector.
+  exact _.
+Defined.
+
+(** As a special case, we get the left module of matrices over a ring. *)
+Global Instance isleftmodule_abgroup_matrix (R : Ring) (m n : nat)
+  : IsLeftModule R (abgroup_matrix R m n)
+  := _.
+
+Definition matrix_lact {R : Ring} {m n : nat} (r : R) (M : Matrix R m n)
+  : Matrix R m n
+  := lact r M.  
+
+(** ** Multiplication *)
+
+(** Matrix multiplication is defined such that the entry at row [i] and column [j] of the resulting matrix is the sum of the products of the corresponding entries from the [i]th row of the first matrix and the [j]th column of the second matrix. Matrices correspond to module homomorphisms between free modules of finite rank (think vector spaces), and matrix multiplication represents the composition of these homomorphisms. **)
+Definition matrix_mult {R : Ring@{i}} {m n k : nat} (M : Matrix R m n) (N : Matrix R n k)
+  : Matrix R m k.
+Proof.
+  snrapply Build_Matrix.
+  intros i j Hi Hj.
+  exact (ab_sum n (fun k Hk => entry M i k * entry N k j)).
+Defined.
+
+(** The identity matrix is the matrix with ones on the diagonal and zeros elsewhere. It acts as the multiplicative identity for matrix multiplication. We define it here using the [kronecker_delta] function which will make proving properties about it conceptually easier later. *)
+Definition identity_matrix (R : Ring@{i}) (n : nat) : Matrix R n n
+  := Build_Matrix R n n (fun i j _ _ => kronecker_delta i j).
+
+(** This is the most general statement of associativity for matrix multiplication. *)
+Definition associative_matrix_mult (R : Ring) (m n p q : nat)
+  : HeteroAssociative
+      (@matrix_mult R m n q) (@matrix_mult R n p q)
+      (@matrix_mult R m p q) (@matrix_mult R m n p).
+Proof.
+  intros M N P; nrapply path_matrix; intros i j Hi Hj.
+  rewrite 2 entry_Build_Matrix.
+  lhs nrapply path_ab_sum.
+  { intros k Hk.
+    rewrite entry_Build_Matrix.
+    apply rng_sum_dist_l. }
+  lhs nrapply ab_sum_sum.
+  rhs nrapply path_ab_sum.
+  2: intros k Hk; by rewrite entry_Build_Matrix.
+  nrapply path_ab_sum.
+  intros k Hk.
+  rhs nrapply rng_sum_dist_r.
+  nrapply path_ab_sum.
+  intros l Hl.
+  apply associativity.
+Defined.
+
+(** Matrix multiplication distributes over addition of matrices on the left. *)
+Definition left_distribute_matrix_mult (R : Ring) (m n p : nat)
+  : LeftHeteroDistribute (@matrix_mult R m n p) matrix_plus matrix_plus.
+Proof.
+  intros M N P; apply path_matrix; intros i j Hi Hj.
+  rewrite !entry_Build_Matrix, !entry_Build_Vector.
+  change (?x = ?y + ?z) with (x = sg_op y z).
+  rewrite <- ab_sum_plus.
+  nrapply path_ab_sum.
+  intros k Hk.
+  rewrite entry_Build_Matrix.
+  apply rng_dist_l.
+Defined.
+
+(** Matrix multiplication distributes over addition of matrices on the right. *)
+Definition right_distribute_matrix_mult (R : Ring) (m n p : nat)
+  : RightHeteroDistribute (@matrix_mult R m n p) matrix_plus matrix_plus.
+Proof.
+  intros M N P; apply path_matrix; intros i j Hi Hj.
+  rewrite !entry_Build_Matrix, !entry_Build_Vector.
+  change (?x = ?y + ?z) with (x = sg_op y z).
+  rewrite <- ab_sum_plus.
+  nrapply path_ab_sum.
+  intros k Hk.
+  rewrite entry_Build_Matrix.
+  apply rng_dist_r.
+Defined.
+
+(** The identity matrix acts as a left identity for matrix multiplication. *)
+Definition left_identity_matrix_mult (R : Ring) (m n: nat)
+  : LeftIdentity (@matrix_mult R m m n) (identity_matrix R m).
+Proof.
+  intros M; apply path_matrix; intros i j Hi Hj.
+  rewrite entry_Build_Matrix.
+  lhs nrapply path_ab_sum.
+  1: intros k Hk; by rewrite entry_Build_Matrix.
+  nrapply rng_sum_kronecker_delta_l.
+Defined.
+
+(** The identity matrix acts as a right identity for matrix multiplication. *)
+Definition right_identity_matrix_mult (R : Ring) (m n : nat)
+  : RightIdentity (@matrix_mult R m n n) (identity_matrix R n).
+Proof.
+  intros M; apply path_matrix; intros i j Hi Hj.
+  rewrite entry_Build_Matrix.
+  lhs nrapply path_ab_sum.
+  1: intros k Hk; by rewrite entry_Build_Matrix.
+  nrapply rng_sum_kronecker_delta_r'.
+Defined.
+
+(** TODO: define this as an R-algebra. What is an R-algebra over a non-commutative right however? (Here we have a bimodule which might be important) *)
+(** Matrices over a ring form a (generally) non-commutative ring. *)
+Definition matrix_ring (R : Ring@{i}) (n : nat) : Ring.
+Proof.
+  snrapply Build_Ring.
+  6: repeat split.
+  - exact (abgroup_matrix R n n).
+  - exact matrix_mult.
+  - exact (identity_matrix R n).
+  - exact (left_distribute_matrix_mult R n n n).
+  - exact (right_distribute_matrix_mult R n n n).
+  - exact _.
+  - exact (associative_matrix_mult R n n n n).
+  - exact (left_identity_matrix_mult R n n).
+  - exact (right_identity_matrix_mult R n n).
+Defined.
+
+(** Matrix multiplication on the right preserves scalar multiplication in the sense that [matrix_lact r (matrix_mult M N) = matrix_mult (matrix_lact r M) N] for [r] a ring element and [M] and [N] matrices of compatible sizes. *)
+Definition matrix_mult_lact_l {R : Ring} {m n p : nat}
+  : HeteroAssociative (@matrix_lact R m p) (@matrix_mult R m n p)
+      (@matrix_mult R m n p) (@matrix_lact R m n).
+Proof.
+  intros r M N.
+  snrapply path_matrix.
+  intros i j Hi Hj.
+  rewrite !entry_Build_Matrix, !entry_Build_Vector. 
+  lhs nrapply rng_sum_dist_l.
+  snrapply path_ab_sum.
+  intros k Hk; cbn.
+  rewrite !entry_Build_Matrix.
+  snrapply rng_mult_assoc.
+Defined.
+
+(** The same doesn't hold for the right matrix, since the ring is not commutative. However we could say an analagous statement for the right action. We haven't yet stated a definition of right module yet though. *)
+
+(** In a commutative ring, matrix multiplication over the ring and the opposite ring agree. *)
+Definition matrix_mult_rng_op {R : CRing} {m n p}
+  (M : Matrix R m n) (N : Matrix R n p)
+  : matrix_mult (R:=rng_op R) M N = matrix_mult M N.
+Proof.
+  apply path_matrix; intros i j Hi Hj.
+  rewrite 2 entry_Build_Matrix.
+  apply path_ab_sum; intros k Hk.
+  apply rng_mult_comm.
+Defined.
+
+(** ** Transpose *)
+
+(** The transpose of a matrix is the matrix with the rows and columns swapped. *)
+Definition matrix_transpose {R : Type} {m n} : Matrix R m n -> Matrix R n m
+  := fun M => Build_Matrix R n m (fun i j H1 H2 => entry M j i).
+
+(** Tranposing a matrix is involutive. *)
+Definition matrix_transpose_transpose {R : Type} {m n} (M : Matrix R m n)
+  : matrix_transpose (matrix_transpose M) = M.
+Proof.
+  apply path_matrix.
+  intros i j Hi Hj.
+  lhs nrapply entry_Build_Matrix.
+  nrapply entry_Build_Matrix.
+Defined.
+
+(** Transpose distributes over addition. *)
+Definition matrix_transpose_plus {R : Ring} {m n} (M N : Matrix R m n)
+  : matrix_transpose (matrix_plus M N)
+    = matrix_plus (matrix_transpose M) (matrix_transpose N).
+Proof.
+  apply path_matrix.
+  intros i j Hi Hj.
+  by rewrite !entry_Build_Matrix, !entry_Build_Vector.
+Defined.
+
+(** Transpose commutes with scalar multiplication. *)
+Definition matrix_transpose_lact {R : Ring} {m n} (r : R) (M : Matrix R m n)
+  : matrix_transpose (matrix_lact r M)
+    = matrix_lact r (matrix_transpose M).
+Proof.
+  apply path_matrix.
+  intros i j Hi Hj.
+  by rewrite !entry_Build_Matrix, !entry_Build_Vector.
+Defined.
+
+(** The negation of a transposed matrix is the same as the transposed matrix of the negation. *)
+Definition matrix_transpose_negate {R : Ring} {m n} (M : Matrix R m n)
+  : matrix_transpose (matrix_negate M) = matrix_negate (matrix_transpose M).
+Proof.
+  apply path_matrix.
+  intros i j Hi Hj.
+  by rewrite !entry_Build_Matrix, !entry_Build_Vector.
+Defined.
+
+(** Transpose distributes over multiplication when you reverse the ring multiplication. *)
+Definition matrix_transpose_mult {R : Ring} {m n p}
+  (M : Matrix R m n) (N : Matrix R n p)
+  : matrix_transpose (matrix_mult M N)
+    = matrix_mult (R:=rng_op R) (matrix_transpose N) (matrix_transpose M).
+Proof.
+  apply path_matrix.
+  intros i j Hi Hj.
+  rewrite 3 entry_Build_Matrix.
+  apply path_ab_sum.
+  intros k Hk.
+  rewrite 2 entry_Build_Matrix.
+  reflexivity.
+Defined.
+
+(** When the ring is commutative, there is no need to reverse the multiplication. *)
+Definition matrix_transpose_mult_comm {R : CRing} {m n p}
+  (M : Matrix R m n) (N : Matrix R n p)
+  : matrix_transpose (matrix_mult M N)
+    = matrix_mult (matrix_transpose N) (matrix_transpose M).
+Proof.
+  lhs nrapply matrix_transpose_mult.
+  apply matrix_mult_rng_op.
+Defined.
+
+(** The transpose of the zero matrix is the zero matrix. *)
+Definition matrix_transpose_zero {R : Ring} {m n}
+  : matrix_transpose (matrix_zero R m n) = matrix_zero R n m.
+Proof.
+  apply path_matrix.
+  intros i j Hi Hj.
+  by rewrite !entry_Build_Matrix.
+Defined.
+
+(** The transpose of the identity matrix is the identity matrix. *)
+Definition matrix_transpose_identity@{i} {R : Ring@{i}} {n}
+  : matrix_transpose (identity_matrix R n) = identity_matrix R n.
+Proof.
+  apply path_matrix.
+  intros i j Hi Hj.
+  rewrite 3 entry_Build_Matrix.
+  apply kronecker_delta_symm.
+Defined.
+
+(** ** Diagonal matrices *)
+
+(** A diagonal matrix is a matrix with zeros everywhere except on the diagonal. Its entries are given by a vector. *)
+Definition matrix_diag {R : Ring@{i}} {n : nat} (v : Vector R n)
+  : Matrix R n n.
+Proof.
+  snrapply Build_Matrix.
+  intros i j H1 H2.
+  exact (kronecker_delta i j * Vector.entry v i).
+Defined.
+
+(** Addition of diagonal matrices is the same as addition of the corresponding vectors. *)
+Definition matrix_diag_plus {R : Ring@{i}} {n : nat} (v w : Vector R n)
+  : matrix_plus (matrix_diag v) (matrix_diag w) = matrix_diag (vector_plus v w).
+Proof.
+  symmetry.
+  snrapply path_matrix.
+  intros i j Hi Hj.
+  rewrite 2 entry_Build_Matrix, 5 entry_Build_Vector.
+  nrapply rng_dist_l.
+Defined.
+
+(** Matrix multiplication of diagonal matrices is the same as multiplying the corresponding vectors pointwise. *)
+Definition matrix_diag_mult {R : Ring} {n : nat} (v w : Vector R n)
+  : matrix_mult (matrix_diag v) (matrix_diag w)
+    = matrix_diag (vector_map2 (.*.) v w).
+Proof.
+  snrapply path_matrix.
+  intros i j Hi Hj.
+  rewrite 2 entry_Build_Matrix.
+  lhs snrapply path_ab_sum.
+  { intros k Hk.
+    rewrite 2 entry_Build_Matrix.
+    rewrite rng_mult_assoc.
+    rewrite <- (rng_mult_assoc (kronecker_delta _ _)).
+    rewrite kronecker_delta_comm.
+    rewrite <- 2 rng_mult_assoc.
+    reflexivity. }
+  rewrite (rng_sum_kronecker_delta_l _ _ Hi).
+  by rewrite entry_Build_Vector.
+Defined.
+
+(** The transpose of a diagonal matrix is the same diagonal matrix. *)
+Definition matrix_transpose_diag {R : Ring@{i}} {n : nat} (v : Vector R n)
+  : matrix_transpose (matrix_diag v) = matrix_diag v.
+Proof.
+  snrapply path_matrix.
+  intros i j Hi Hj.
+  rewrite 3 entry_Build_Matrix.
+  rewrite kronecker_delta_symm.
+  unfold kronecker_delta.
+  destruct (dec (i = j)) as [p|np].
+  1: f_ap; symmetry; by apply path_entry_vector.
+  by rewrite !rng_mult_zero_l.
+Defined.
+
+(** The diagonal matrix construction is injective. *)
+Global Instance isinj_matrix_diag {R : Ring@{i}} {n : nat}
+  : IsInjective (@matrix_diag R n).
+Proof.
+  intros v1 v2 p.
+  snrapply path_vector.
+  intros i Hi.
+  apply (ap (fun M => entry M i i)) in p.
+  rewrite 2 entry_Build_Matrix in p.
+  rewrite kronecker_delta_refl in p.
+  by rewrite 2 rng_mult_one_l in p.
+Defined.
+
+(** A matrix is diagonal if it is equal to a diagonal matrix. *)
+Class IsDiagonal@{i} {R : Ring@{i}} {n : nat} (M : Matrix R n n) : Type@{i} := {
+  isdiagonal_diag_vector : Vector R n;
+  isdiagonal_diag : M = matrix_diag isdiagonal_diag_vector;
+}.
+
+Arguments isdiagonal_diag_vector {R n} M {_}.
+Arguments isdiagonal_diag {R n} M {_}.
+
+Definition issig_IsDiagonal {R : Ring@{i}} {n : nat} {M : Matrix R n n}
+  : _ <~> IsDiagonal M
+  := ltac:(issig).
+
+(** A matrix is diagonal in a unique way. *)
+Global Instance ishprop_isdiagonal {R : Ring@{i}} {n : nat} (M : Matrix R n n)
+  : IsHProp (IsDiagonal M).
+Proof.
+  snrapply hprop_allpath.
+  intros x y.
+  snrapply ((equiv_ap' issig_IsDiagonal^-1%equiv _ _ )^-1%equiv).
+  rapply path_sigma_hprop; cbn.
+  apply isinj_matrix_diag.
+  exact ((isdiagonal_diag M)^ @ isdiagonal_diag M).
+Defined.
+
+(** The zero matrix is diagonal. *)
+Global Instance isdiagonal_matrix_zero {R : Ring@{i}} {n : nat}
+  : IsDiagonal (matrix_zero R n n).
+Proof.
+  exists (vector_zero R n).
+  snrapply path_matrix.
+  intros i j Hi Hj.
+  rewrite 2 entry_Build_Matrix, entry_Build_Vector.
+  by rewrite rng_mult_zero_r.
+Defined.
+
+(** The identity matrix is diagonal. *)
+Global Instance isdiagonal_identity_matrix {R : Ring@{i}} {n : nat}
+  : IsDiagonal (identity_matrix R n).
+Proof.
+  exists (Build_Vector R n (fun _ _ => 1)).
+  snrapply path_matrix.
+  intros i j Hi Hj.
+  rewrite 2 entry_Build_Matrix, entry_Build_Vector.
+  by rewrite rng_mult_one_r.
+Defined.
+
+(** The sum of two diagonal matrices is diagonal. *)
+Global Instance isdiagonal_matrix_plus {R : Ring@{i}} {n : nat}
+  (M N : Matrix R n n) `{IsDiagonal R n M} `{IsDiagonal R n N}
+  : IsDiagonal (matrix_plus M N).
+Proof.
+  exists (vector_plus (isdiagonal_diag_vector M) (isdiagonal_diag_vector N)).
+  rewrite (isdiagonal_diag M), (isdiagonal_diag N).
+  apply matrix_diag_plus.
+Defined.
+
+(** The negative of a diagonal matrix is diagonal. *)
+Global Instance isdiagonal_matrix_negate {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{IsDiagonal R n M}
+  : IsDiagonal (matrix_negate M).
+Proof.
+  exists (vector_neg _ _ (isdiagonal_diag_vector M)).
+  rewrite (isdiagonal_diag M).
+  snrapply path_matrix.
+  intros i j Hi Hj.
+  rewrite !entry_Build_Matrix, !entry_Build_Vector.
+  by rewrite rng_mult_negate_r.
+Defined.
+
+(** The product of two diagonal matrices is diagonal. *)
+Global Instance isdiagonal_matrix_mult {R : Ring@{i}} {n : nat}
+  (M N : Matrix R n n) `{IsDiagonal R n M} `{IsDiagonal R n N}
+  : IsDiagonal (matrix_mult M N).
+Proof.
+  exists (vector_map2 (.*.) (isdiagonal_diag_vector M) (isdiagonal_diag_vector N)).
+  rewrite (isdiagonal_diag M), (isdiagonal_diag N).
+  apply matrix_diag_mult.
+Defined.
+
+(** The transpose of a diagonal matrix is diagonal. *)
+Global Instance isdiagonal_matrix_transpose {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{IsDiagonal R n M}
+  : IsDiagonal (matrix_transpose M).
+Proof.
+  exists (isdiagonal_diag_vector M).
+  rewrite (isdiagonal_diag M).
+  apply matrix_transpose_diag.
+Defined.
+
+(** Given a square matrix, we can extract the diagonal as a vector. *)
+Definition matrix_diag_vector {R : Ring} {n : nat} (M : Matrix R n n)
+  : Vector R n
+  := Build_Vector R n (fun i _ => entry M i i).
+
+(** Diagonal matrices form a subring of the ring of square matrices. *)
+Definition matrix_diag_ring@{i} (R : Ring@{i}) (n : nat)
+  : Subring@{i i} (matrix_ring R n).
+Proof.
+  snrapply (Build_Subring' (fun M : matrix_ring R n => IsDiagonal M) _); hnf.
+  - intros; exact _.
+  - intros x y dx dy.
+    nrapply isdiagonal_matrix_plus; trivial.
+    by nrapply isdiagonal_matrix_negate.
+  - nrapply isdiagonal_matrix_mult.
+  - nrapply isdiagonal_identity_matrix.
+Defined.
+
+(** ** Trace *)
+
+(** The trace of a square matrix is the sum of the diagonal entries. *)
+Definition matrix_trace {R : Ring} {n} (M : Matrix R n n) : R
+  := ab_sum n (fun i Hi => entry M i i).
+
+(** The trace of a matrix preserves addition. *)
+Definition matrix_trace_plus {R : Ring} {n} (M N : Matrix R n n)
+  : matrix_trace (matrix_plus M N) = (matrix_trace M) + (matrix_trace N).
+Proof.
+  unfold matrix_trace.
+  lhs nrapply path_ab_sum.
+  { intros i Hi.
+    by rewrite entry_Build_Matrix. }
+  by rewrite ab_sum_plus.
+Defined.
+
+(** The trace of a matrix preserves scalar multiplication. *)
+Definition matrix_trace_lact {R : Ring} {n} (r : R) (M : Matrix R n n)
+  : matrix_trace (matrix_lact r M) = r * matrix_trace M.
+Proof.
+  unfold matrix_trace.
+  rewrite rng_sum_dist_l.
+  apply path_ab_sum.
+  intros i Hi.
+  by rewrite entry_Build_Matrix.
+Defined.
+
+(** The trace of a matrix multiplication is the same as the trace of the reverse multiplication. This holds only in a commutative ring. *)
+Definition matrix_trace_mult {R : CRing} {m n : nat}
+  (M : Matrix R m n) (N : Matrix R n m)
+  : matrix_trace (matrix_mult M N) = matrix_trace (matrix_mult N M).
+Proof.
+  lhs nrapply path_ab_sum.
+  { intros i Hi.
+    lhs nrapply entry_Build_Matrix.
+    nrapply path_ab_sum.
+    intros j Hj.
+    apply rng_mult_comm. }
+  lhs nrapply ab_sum_sum.
+  apply path_ab_sum.
+  intros i Hi.
+  rhs nrapply entry_Build_Matrix.
+  reflexivity.
+Defined.
+
+(** The trace of the transpose of a matrix is the same as the trace of the matrix. *)
+Definition trace_transpose {R : Ring} {n} (M : Matrix R n n)
+  : matrix_trace (matrix_transpose M) = matrix_trace M.
+Proof.
+  apply path_ab_sum.
+  intros i Hi.
+  nrapply entry_Build_Matrix.
+Defined.
+
+(** ** Matrix minors *)
+
+Definition skip (n : nat) : nat -> nat
+  := fun i => if dec (i < n)%nat then i else i.+1%nat.
+
+Global Instance isinjective_skip n : IsInjective (skip n).
+Proof.
+  hnf.
+  intros x y p.
+  unfold skip in p.
+  destruct (dec (x < n)%nat) as [H|H], (dec (y < n)%nat) as [H'|H'].
+  - exact p.
+  - destruct p^.
+    contradiction (H' (leq_trans _ H)).
+  - destruct p.
+    contradiction (H (leq_trans _ H')).
+  - by apply path_nat_succ.
+Defined.
+
+Local Instance lt_n1_skip k i n (H : (i < n.+1)%nat) (H' : (k < n)%nat)
+  : (skip i k < n.+1)%nat.
+Proof.
+  unfold skip.
+  destruct (dec (k < i))%nat as [H''|H'']; exact _.
+Defined.
+
+Definition matrix_minor {R : Ring@{i}} {n : nat} (i j : nat)
+  {Hi : (i < n.+1)%nat} {Hj : (j < n.+1)%nat} (M : Matrix R n.+1 n.+1)
+  : Matrix R n n
+  := Build_Matrix R n n (fun k l _ _ => entry M (skip i k) (skip j l)).
+
+(** A minor of the zero matrix is again the zero matrix. *)
+Definition matrix_minor_zero {R : Ring@{i}} {n : nat} (i j : nat)
+  (Hi : (i < n.+1)%nat) (Hj : (j < n.+1)%nat)
+  : matrix_minor i j (matrix_zero R n.+1 n.+1) = matrix_zero R n n.
+Proof.
+  apply path_matrix.
+  intros k l Hk Hl.
+  by rewrite !entry_Build_Matrix.
+Defined.
+
+Definition matrix_minor_identity {R : Ring@{i}} {n : nat}
+  (i : nat) (Hi : (i < n.+1)%nat)
+  : matrix_minor i i (identity_matrix R n.+1) = identity_matrix R n.
+Proof.
+  apply path_matrix.
+  intros j k Hj Hk.
+  rewrite 3 entry_Build_Matrix.
+  rapply kronecker_delta_map_inj.
+Defined.
+
+Definition matrix_minor_plus {R : Ring@{i}} {n : nat} (i j : nat)
+  (Hi : (i < n.+1)%nat) (Hj : (j < n.+1)%nat) (M N : Matrix R n.+1 n.+1)
+  : matrix_minor i j (matrix_plus M N)
+    = matrix_plus (matrix_minor i j M) (matrix_minor i j N).
+Proof.
+  apply path_matrix.
+  intros k l Hk Hl.
+  by rewrite !entry_Build_Matrix, !entry_Build_Vector.
+Defined.
+
+Definition matrix_minor_scale {R : Ring@{i}} {n : nat} (i j : nat)
+  (Hi : (i < n.+1)%nat) (Hj : (j < n.+1)%nat) (r : R) (M : Matrix R n.+1 n.+1)
+  : matrix_minor i j (matrix_lact r M) = matrix_lact r (matrix_minor i j M).
+Proof.
+  apply path_matrix.
+  intros k l Hk Hl.
+  by rewrite !entry_Build_Matrix, !entry_Build_Vector.
+Defined.
+
+Definition matrix_minor_transpose {R : Ring@{i}} {n : nat} (i j : nat)
+  (Hi : (i < n.+1)%nat) (Hj : (j < n.+1)%nat) (M : Matrix R n.+1 n.+1)
+  : matrix_minor j i (matrix_transpose M)
+    = matrix_transpose (matrix_minor i j M).
+Proof.
+  apply path_matrix.
+  intros k l Hk Hl.
+  by rewrite 4 entry_Build_Matrix.
+Defined.
+
+(** ** Triangular matrices *)
+
+(** A matrix is upper triangular if all the entries below the diagonal are zero. *)
+Class IsUpperTriangular@{i} {R : Ring@{i}} {n : nat} (M : Matrix@{i} R n n) : Type@{i}
+  := upper_triangular
+  : merely@{i} (forall i j (Hi : (i < n)%nat) (Hj : (j < n)%nat), (i < j)%nat -> entry M i j = 0).
+
+Global Instance ishprop_isuppertriangular@{i} {R : Ring@{i}} {n : nat} (M : Matrix R n n)
+  : IsHProp (IsUpperTriangular M).
+Proof.
+  apply istrunc_truncation@{i i}.
+Defined.
+
+(** A matrix is lower triangular if all the entries above the diagonal are zero. We define it as the transpose being upper triangular. *)
+Class IsLowerTriangular {R : Ring@{i}} {n : nat} (M : Matrix@{i} R n n) : Type@{i}
+  := upper_triangular_transpose :: IsUpperTriangular (matrix_transpose M).
+
+Global Instance ishprop_islowertriangular@{i} {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n)
+  : IsHProp (IsLowerTriangular M).
+Proof.
+  apply istrunc_truncation@{i i}.
+Defined.
+
+(** The transpose of a matrix is lower triangular if and only if the matrix is upper triangular. *)
+Global Instance lower_triangular_transpose {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{!IsUpperTriangular M}
+  : IsLowerTriangular (matrix_transpose M).
+Proof.
+  unfold IsLowerTriangular.
+  by rewrite matrix_transpose_transpose.
+Defined.
+
+(** The sum of two upper triangular matrices is upper triangular. *)
+Global Instance upper_triangular_plus {R : Ring@{i}} {n : nat} (M N : Matrix R n n)
+  {H1 : IsUpperTriangular M} {H2 : IsUpperTriangular N}
+  : IsUpperTriangular (matrix_plus M N).
+Proof.
+  unfold IsUpperTriangular.
+  strip_truncations; apply tr.
+  intros i j Hi Hj lt_i_j.
+  specialize (H1 i j Hi Hj lt_i_j).
+  specialize (H2 i j Hi Hj lt_i_j).
+  rewrite entry_Build_Matrix.
+  change (Vector.entry (Vector.entry ?M ?i) ?j) with (entry M i j).
+  rewrite H1, H2.
+  by rewrite rng_plus_zero_l.
+Defined.
+
+(** The sum of two lower triangular matrices is lower triangular. *)
+Global Instance lower_triangular_plus {R : Ring@{i}} {n : nat}
+  (M N : Matrix R n n) `{!IsLowerTriangular M} `{!IsLowerTriangular N}
+  : IsLowerTriangular (matrix_plus M N).
+Proof.
+  unfold IsLowerTriangular.
+  rewrite matrix_transpose_plus.
+  by apply upper_triangular_plus.
+Defined.
+
+(** The negation of an upper triangular matrix is upper triangular. *)
+Global Instance upper_triangular_negate {R : Ring@{i}} {n : nat} (M : Matrix R n n)
+  {H : IsUpperTriangular M}
+  : IsUpperTriangular (matrix_negate M).
+Proof.
+  unfold IsUpperTriangular.
+  strip_truncations; apply tr.
+  intros i j Hi Hj lt_i_j.
+  rewrite entry_Build_Matrix.
+  rewrite <- rng_negate_zero; f_ap.
+  by nrapply H.
+Defined.
+
+(** The negation of a lower triangular matrix is lower triangular. *)
+Global Instance lower_triangular_negate {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{!IsLowerTriangular M}
+  : IsLowerTriangular (matrix_negate M).
+Proof.
+  unfold IsLowerTriangular.
+  rewrite matrix_transpose_negate.
+  exact _.
+Defined.
+
+(** The product of two upper triangular matrices is upper triangular. *)
+Global Instance upper_triangular_mult {R : Ring@{i}} {n : nat}
+  (M N : Matrix R n n) {H1 : IsUpperTriangular M} {H2 : IsUpperTriangular N}
+  : IsUpperTriangular (matrix_mult M N).
+Proof.
+  unfold IsUpperTriangular.
+  strip_truncations; apply tr.
+  intros i j Hi Hj lt_i_j.
+  rewrite entry_Build_Matrix.
+  apply ab_sum_zero.
+  intros k Hk.
+  destruct (dec (k <= i)%nat) as [leq_k_i|gt_k_i].
+  { rewrite H2.
+    1: by rewrite rng_mult_zero_r.
+    rapply lt_leq_lt_trans. }
+  apply gt_iff_not_leq in gt_k_i.
+  rewrite H1.
+  1: by rewrite rng_mult_zero_l.
+  assumption.
+Defined.
+
+(** The product of two lower triangular matrices is lower triangular. *)
+Global Instance lower_triangular_mult {R : Ring@{i}} {n : nat}
+  (M N : Matrix R n n) {H1 : IsLowerTriangular M} {H2 : IsLowerTriangular N}
+  : IsLowerTriangular (matrix_mult M N).
+Proof.
+  unfold IsLowerTriangular.
+  rewrite matrix_transpose_mult.
+  nrapply (upper_triangular_mult (R:=rng_op R)); assumption.
+Defined.
+
+(** The zero matrix is upper triangular. *)
+Global Instance upper_triangular_zero {R : Ring@{i}} {n : nat}
+  : IsUpperTriangular (matrix_zero R n n).
+Proof.
+  apply tr.
+  by hnf; intros; rewrite entry_Build_Matrix.
+Defined.
+
+(** The zero matrix is lower triangular. *)
+Global Instance lower_triangular_zero {R : Ring@{i}} {n : nat}
+  : IsLowerTriangular (matrix_zero R n n).
+Proof.
+  unfold IsLowerTriangular.
+  rewrite matrix_transpose_zero.
+  exact _.
+Defined.
+
+(** The identity matrix is upper triangular. *)
+Global Instance upper_triangular_identity@{i} {R : Ring@{i}} {n : nat}
+  : IsUpperTriangular (identity_matrix R n).
+Proof.
+  unfold IsUpperTriangular.
+  apply tr@{i}.
+  intros i j Hi Hj lt_i_j.
+  rewrite entry_Build_Matrix@{i}.
+  by apply kronecker_delta_lt.
+Defined.
+
+(** The identity matrix is lower triangular. *)
+Global Instance lower_triangular_identity@{i} {R : Ring@{i}} {n : nat}
+  : IsLowerTriangular (identity_matrix R n).
+Proof.
+  unfold IsLowerTriangular.
+  rewrite matrix_transpose_identity.
+  exact _.
+Defined.
+
+(** A diagonal matrix is upper triangular. *)
+Global Instance upper_triangular_diag {R : Ring@{i}} {n : nat} (v : Vector R n)
+  : IsUpperTriangular (matrix_diag v).
+Proof.
+  unfold IsUpperTriangular.
+  apply tr.
+  intros i j Hi Hj lt_i_j.
+  rewrite entry_Build_Matrix.
+  rewrite kronecker_delta_lt.
+  1: by rewrite rng_mult_zero_l.
+  exact _.
+Defined.
+
+(** A diagonal matrix is lower triangular. *)
+Global Instance lower_triangular_diag {R : Ring@{i}} {n : nat} (v : Vector R n)
+  : IsLowerTriangular (matrix_diag v).
+Proof.
+  unfold IsLowerTriangular.
+  rewrite matrix_transpose_diag.
+  apply upper_triangular_diag.
+Defined.
+
+(** Upper triangular matrices are a subring of the ring of matrices. *)
+Definition upper_triangular_matrix_ring@{i} (R : Ring@{i}) (n : nat)
+  : Subring@{i i} (matrix_ring@{i} R n).
+Proof.
+  nrapply (Build_Subring' (fun M : matrix_ring R n => IsUpperTriangular M)).
+  - exact _.
+  (* These can all be found by typeclass search, but being explicit makes this faster. *)
+  - intros x y ? ?; exact (upper_triangular_plus x (-y)).
+  - exact upper_triangular_mult.
+  - exact upper_triangular_identity.
+Defined.
+
+(** Lower triangular matrices are a subring of the ring of matrices. *)
+Definition lower_triangular_matrix_ring@{i} (R : Ring@{i}) (n : nat)
+  : Subring@{i i} (matrix_ring R n).
+Proof.
+  nrapply (Build_Subring'@{i i} (fun M : matrix_ring R n => IsLowerTriangular M)).
+  - exact _.
+  (* These can all be found by typeclass search, but being explicit makes this faster. *)
+  - intros x y ? ?; exact (lower_triangular_plus x (-y)).
+  - exact lower_triangular_mult.
+  - exact lower_triangular_identity.
+Defined.
+
+(** ** Symmetric Matrices *)
+
+(** A matrix is symmetric when it is equal to its transpose. *)
+Class IsSymmetric {R : Ring@{i}} {n : nat} (M : Matrix@{i} R n n) : Type@{i}
+  := matrix_transpose_issymmetric : matrix_transpose M = M.
+
+Arguments matrix_transpose_issymmetric {R n} M {_}.
+
+(** The zero matrix is symmetric. *)
+Global Instance issymmetric_matrix_zero {R : Ring@{i}} {n : nat}
+  : IsSymmetric (matrix_zero R n n)
+  := matrix_transpose_zero.
+
+(** The identity matrix is symmetric. *)
+Global Instance issymmetric_matrix_identity {R : Ring@{i}} {n : nat}
+  : IsSymmetric (identity_matrix R n)
+  := matrix_transpose_identity.
+
+(** The sum of two symmetric matrices is symmetric. *)
+Global Instance issymmetric_matrix_plus {R : Ring@{i}} {n : nat}
+  (M N : Matrix R n n) `{!IsSymmetric M} `{!IsSymmetric N}
+  : IsSymmetric (matrix_plus M N).
+Proof.
+  unfold IsSymmetric.
+  rewrite matrix_transpose_plus.
+  f_ap.
+Defined.
+
+(** The negation of a symmetric matrix is symmetric. *)
+Global Instance issymmetric_matrix_negate {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{!IsSymmetric M}
+  : IsSymmetric (matrix_negate M).
+Proof.
+  unfold IsSymmetric.
+  rewrite matrix_transpose_negate.
+  f_ap.
+Defined.
+
+(** A scalar multiple of a symmetric matrix is symmetric. *)
+Global Instance issymmetric_matrix_scale {R : Ring@{i}} {n : nat}
+  (r : R) (M : Matrix R n n) `{!IsSymmetric M}
+  : IsSymmetric (matrix_lact r M).
+Proof.
+  unfold IsSymmetric.
+  rewrite matrix_transpose_lact.
+  f_ap.
+Defined.
+
+(** The transpose of a symmetric matrix is symmetric. *)
+Global Instance issymmetric_matrix_transpose {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{!IsSymmetric M}
+  : IsSymmetric (matrix_transpose M).
+Proof.
+  unfold IsSymmetric.
+  rewrite matrix_transpose_transpose.
+  by symmetry.
+Defined.
+
+(** A symmetric upper triangular matrix is diagonal. *)
+Global Instance isdiagonal_upper_triangular_issymmetric {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{!IsSymmetric M} {H : IsUpperTriangular M}
+  : IsDiagonal M.
+Proof.
+  exists (matrix_diag_vector M).
+  snrapply path_matrix.
+  intros i j Hi Hj.
+  rewrite entry_Build_Matrix, entry_Build_Vector.
+  strip_truncations.
+  destruct (dec (i = j)) as [p|np].
+  { destruct p.
+    rewrite kronecker_delta_refl.
+    rewrite rng_mult_one_l.
+    f_ap; apply path_ishprop. }
+  apply neq_iff_lt_or_gt in np.
+  destruct np as [l | l].
+  - rewrite (kronecker_delta_lt l).
+    rewrite rng_mult_zero_l.
+    by rewrite H.
+  - rewrite (kronecker_delta_gt l).
+    rewrite rng_mult_zero_l.
+    rewrite <- (matrix_transpose_issymmetric M).
+    rewrite entry_Build_Matrix.
+    by rewrite H.
+Defined.
+
+(** A symmetric lower triangular matrix is diagonal. *)
+Global Instance isdiagonal_lower_triangular_issymmetric {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{!IsSymmetric M} `{!IsLowerTriangular M}
+  : IsDiagonal M.
+Proof.
+  rewrite <- (matrix_transpose_issymmetric M).
+  rapply isdiagonal_upper_triangular_issymmetric.
+Defined.
+
+(** Note that symmetric matrices do not form a subring (or subalgebra) but they do form a submodule of the module of matrices. *)
+
+(** ** Skew-symmetric Matrices *)
+
+(** A matrix is skew-symmetric when it is equal to the negation of its transpose. *)
+Class IsSkewSymmetric {R : Ring@{i}} {n : nat} (M : Matrix@{i} R n n) : Type@{i}
+  := matrix_transpose_isskewsymmetric : matrix_transpose M = matrix_negate M.
+
+Arguments matrix_transpose_isskewsymmetric {R n} M {_}.
+
+(** The zero matrix is skew-symmetric. *)
+Global Instance isskewsymmetric_matrix_zero {R : Ring@{i}} {n : nat}
+  : IsSkewSymmetric (matrix_zero R n n).
+Proof.
+  unfold IsSkewSymmetric.
+  rewrite matrix_transpose_zero.
+  symmetry.
+  nrapply (rng_negate_zero (A:=matrix_ring R n)).
+Defined.
+
+(** The negation of a skew-symmetric matrix is skew-symmetric. *)
+Global Instance isskewsymmetric_matrix_negate {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{!IsSkewSymmetric M}
+  : IsSkewSymmetric (matrix_negate M).
+Proof.
+  unfold IsSkewSymmetric.
+  rewrite matrix_transpose_negate.
+  f_ap.
+Defined.
+
+(** A scalar multiple of a skew-symmetric matrix is skew-symmetric. *)
+Global Instance isskewsymmetric_matrix_scale {R : Ring@{i}} {n : nat}
+  (r : R) (M : Matrix R n n) `{!IsSkewSymmetric M}
+  : IsSkewSymmetric (matrix_lact r M).
+Proof.
+  unfold IsSkewSymmetric.
+  rewrite matrix_transpose_lact.
+  rhs_V nrapply (lm_neg (M:=Build_LeftModule _ (abgroup_matrix R n n) _) r M).
+  f_ap.
+Defined.
+
+(** The transpose of a skew-symmetric matrix is skew-symmetric. *)
+Global Instance isskewsymmetric_matrix_transpose {R : Ring@{i}} {n : nat}
+  (M : Matrix R n n) `{!IsSkewSymmetric M}
+  : IsSkewSymmetric (matrix_transpose M).
+Proof.
+  unfold IsSkewSymmetric.
+  rewrite <- matrix_transpose_negate.
+  f_ap.
+Defined.
+
+(** The sum of two skew-symmetric matrices is skew-symmetric. *)
+Global Instance isskewsymmetric_matrix_plus {R : Ring@{i}} {n : nat}
+  (M N : Matrix R n n) `{!IsSkewSymmetric M} `{!IsSkewSymmetric N}
+  : IsSkewSymmetric (matrix_plus M N).
+Proof.
+  unfold IsSkewSymmetric.
+  rewrite matrix_transpose_plus.
+  rhs nrapply (grp_inv_op (G:=abgroup_matrix R n n)).
+  rhs_V nrapply (AbelianGroup.ab_comm (A:=abgroup_matrix R n n)).
+  f_ap.
+Defined.
+
+(** Skew-symmetric matrices degenerate to symmetric matrices in rings with characteristic 2. In odd characteristic the module of matrices can be decomposed into the direct sum of symmetric and skew-symmetric matrices. *)
+
+Section MatrixCat.
+
+  (** The wild category [MatrixCat R] of [R]-valued matrices. This category has natural numbers as objects and m x n matrices as the arrows between [m] and [n]. *)
+  Definition MatrixCat (R : Ring) := nat.
+
+  Global Instance isgraph_matrixcat {R : Ring} : IsGraph (MatrixCat R)
+    := {| Hom := Matrix R |}.
+
+  Global Instance is01cat_matrixcat {R : Ring} : Is01Cat (MatrixCat R).
+  Proof.
+    snrapply Build_Is01Cat.
+    - exact (identity_matrix R).
+    - intros l m n M N.
+      exact (matrix_mult N M).
+  Defined.
+
+  Global Instance is2graph_matrixcat {R : Ring} : Is2Graph (MatrixCat R)
+    := is2graph_paths _.
+
+  (** MatrixCat R forms a strong 1-category. *)
+  Global Instance is1catstrong_matrixcat {R : Ring} : Is1Cat_Strong (MatrixCat R).
+  Proof.
+    snrapply Build_Is1Cat_Strong.
+    (* Most of the structure comes from typeclasses in WildCat.Paths. *)
+    1-4: exact _.
+    - apply (associative_matrix_mult R).
+    - intros k l m n M N P. apply inverse. apply (associative_matrix_mult R).
+    - apply right_identity_matrix_mult.
+    - apply left_identity_matrix_mult.
+  Defined.
+
+(** TODO: Define HasEquivs for MatrixCat.  *)
+
+End MatrixCat.
diff --git a/theories/Algebra/Rings/Module.v b/theories/Algebra/Rings/Module.v
new file mode 100644
index 00000000000..a477adff3e2
--- /dev/null
+++ b/theories/Algebra/Rings/Module.v
@@ -0,0 +1,718 @@
+Require Import WildCat.
+Require Import Spaces.Nat.Core.
+(* Some of the material in abstract_algebra and canonical names could be selectively exported to the user, as is done in Groups/Group.v. *)
+Require Import Classes.interfaces.canonical_names.
+Require Import Algebra.Groups.Kernel Algebra.Groups.Image Algebra.Groups.QuotientGroup.
+Require Import Algebra.AbGroups.AbelianGroup Algebra.AbGroups.Biproduct.
+Require Import Rings.Ring.
+
+Declare Scope module_scope.
+Local Open Scope module_scope.
+
+(** * Modules over a ring. *)
+
+(** ** Left Modules *)
+
+(** An abelian group [M] is a left [R]-module when equipped with the following data: *) 
+Class IsLeftModule (R : Ring) (M : AbGroup) := {
+  (** A function [lact] (left-action) that takes an element [r : R] and an element [m : M] and returns an element [lact r m : M], which we also denote [r *L m]. *)
+  lact : R -> M -> M;
+  (** Actions distribute on the left over addition in the abelian group. That is [r *L (m + n) = r *L m + r *L n]. *)
+  lact_left_dist :: LeftHeteroDistribute lact (+) (+);
+  (** Actions distribute on the right over addition in the ring. That is [(r + s) *L m = r *L m + s *L m]. *)
+  lact_right_dist :: RightHeteroDistribute lact (+) (+);
+  (** Actions are associative. That is [(r * s) *L m = r *L (s *L m)]. *)
+  lact_assoc :: HeteroAssociative lact lact lact (.*.);
+  (** Actions preserve the multiplicative identity. That is [1 *L m = m]. *)
+  lact_unit :: LeftIdentity lact 1;
+}.
+
+Infix "*L" := lact : module_scope.
+
+(** A left R-module is an abelian group equipped with a left R-module structure. *)
+Record LeftModule (R : Ring) := {
+  lm_carrier :> AbGroup;
+  lm_lact :: IsLeftModule R lm_carrier;
+}.
+
+Section LeftModuleAxioms.
+  Context {R : Ring} {M : LeftModule R} (r s : R) (m n : M).
+  (** Here we state the module axioms in a readable form for direct use. *)
+
+  Definition lm_dist_l : r *L (m + n) = r *L m + r *L n := lact_left_dist r m n.
+  Definition lm_dist_r : (r + s) *L m = r *L m + s *L m := lact_right_dist r s m.
+  Definition lm_assoc : r *L (s *L m) = (r * s) *L m := lact_assoc r s m.
+  Definition lm_unit : 1 *L m = m := lact_unit m.
+  
+End LeftModuleAxioms.
+
+(** ** Facts about left modules *)
+
+Section LeftModuleFacts.
+  Context {R : Ring} {M : LeftModule R} (r : R) (m : M).
+  
+  (** Here are some quick facts that hold in modules. *) 
+
+  (** The left action of zero is zero. *) 
+  Definition lm_zero_l : 0 *L m = 0.
+  Proof.
+    apply (grp_cancelL1 (z := lact 0 m)).
+    lhs_V nrapply lm_dist_r.
+    f_ap.
+    apply rng_plus_zero_r.
+  Defined.
+  
+  (** The left action on zero is zero. *)
+  Definition lm_zero_r : r *L (0 : M) = 0.
+  Proof.
+    apply (grp_cancelL1 (z := lact r 0)).
+    lhs_V nrapply lm_dist_l.
+    f_ap.
+    apply grp_unit_l.
+  Defined.
+
+  (** The left action of [-1] is the additive inverse. *)
+  Definition lm_minus_one : -1 *L m = -m.
+  Proof.
+     apply grp_moveL_1V.
+     lhs nrapply (ap (_ +) (lm_unit m)^).
+     lhs_V nrapply lm_dist_r.
+     rhs_V nrapply lm_zero_l.
+     f_ap.
+     apply grp_inv_l.
+  Defined.
+ 
+  (** The left action of [r] on the additive inverse of [m] is the additive inverse of the left action of [r] on [m]. *)
+  Definition lm_neg : r *L -m = - (r *L m).
+  Proof.
+    apply grp_moveL_1V.
+    lhs_V nrapply lm_dist_l.
+    rhs_V nrapply lm_zero_r.
+    f_ap.
+    apply grp_inv_l.
+  Defined.
+
+End LeftModuleFacts.
+
+(** Every ring [R] is a left [R]-module over itself. *)
+Global Instance isleftmodule_ring (R : Ring) : IsLeftModule R R.
+Proof.
+  rapply Build_IsLeftModule.
+Defined.
+
+(** ** Right Modules *)
+
+(** An abelian group [M] is a right [R]-module when it is a left [R^op]-module. *)
+Class IsRightModule (R : Ring) (M : AbGroup)
+  := isleftmodule_op_isrightmodule :: IsLeftModule (rng_op R) M.
+  
+(** [ract] (right-action) that takes an element [m : M] and an element [r : R] and returns an element [ract m r : M] which we also denote [m *R r]. *)
+Definition ract {R : Ring} {M : AbGroup} `{!IsRightModule R M}
+  : M -> R -> M
+  := fun m r => lact (R:=rng_op R) r m.
+
+Infix "*R" := ract.
+
+(** A right module is a left module over the opposite ring. *)
+Definition RightModule (R : Ring) := LeftModule (rng_op R).
+
+(** Right modules are right modules. *)
+Global Instance rm_ract {R : Ring} {M : RightModule R} : IsRightModule R M
+  := lm_lact (rng_op R) M.
+
+Section RightModuleAxioms.
+  Context {R : Ring} {M : RightModule R} (m n : M) (r s : R).
+  (** Here we state the module axioms in a readable form for direct use. *)
+
+  Definition rm_dist_r : (m + n) *R r = m *R r + n *R r
+    := lm_dist_l (R:=rng_op R) r m n.
+  Definition rm_dist_l : m *R (r + s) = m *R r + m *R s
+    := lm_dist_r (R:=rng_op R) r s m.
+  Definition rm_assoc : (m *R r) *R s = m *R (r * s)
+    := lm_assoc (R:=rng_op R) s r m.
+  Definition rm_unit : m *R 1 = m
+    := lm_unit (R:=rng_op R) m.
+  
+End RightModuleAxioms.
+
+(** ** Facts about right modules *)
+
+Section RightModuleFacts.
+  Context {R : Ring} {M : RightModule R} (m : M) (r : R).
+
+  (** The right action on zero is zero. *)
+  Definition rm_zero_l : (0 : M) *R r = 0
+    := lm_zero_r (R:=rng_op R) r.
+
+  (** The right adtion of zero is zero. *)
+  Definition rm_zero_r : m *R 0 = 0
+    := lm_zero_l (R:=rng_op R) m.
+
+  (** The right action of [-1] is the additive inverse. *)
+  Definition rm_minus_one : m *R -1 = -m
+    := lm_minus_one (R:=rng_op R) m. 
+
+  (** The right action of [r] on the additive inverse of [m] is the additive inverse of the right action of [r] on [m]. *)
+  Definition rm_neg : -m *R r = - (m *R r)
+    := lm_neg (R:=rng_op R) r m. 
+
+End RightModuleFacts.
+
+(** Every ring [R] is a right [R]-module over itself. *)
+Global Instance isrightmodule_ring (R : Ring) : IsRightModule R R
+  := isleftmodule_ring (rng_op R).
+
+(** ** Submodules *)
+
+(** A subgroup of a left R-module is a left submodule if it is closed under the action of R. *)
+Class IsLeftSubmodule {R : Ring} {M : LeftModule R} (N : M -> Type) := {
+  ils_issubgroup :: IsSubgroup N;
+  is_left_submodule : forall r m, N m -> N (r *L m);
+}.
+
+(** A subgroup of a right R-module is a right submodule if it is a left submodule over the opposite ring. *)
+Class IsRightSubmodule {R : Ring} {M : RightModule R} (N : M -> Type)
+  := isleftsubmodule_op_isrightsubmodule :: IsLeftSubmodule (R:=rng_op R) N.
+
+(** A left submodule is a subgroup of the abelian group closed under the left action of R. *)
+Record LeftSubmodule {R : Ring} (M : LeftModule R) := {
+  lsm_carrier :> M -> Type;
+  lsm_submodule :: IsLeftSubmodule lsm_carrier;
+}.
+
+(** A right submodule is a subgroup of the abelian group closed under the right action of R. *)
+Definition RightSubmodule {R : Ring} (M : RightModule R)
+  := LeftSubmodule (R:=rng_op R) M.
+
+Definition subgroup_leftsubmodule {R : Ring} {M : LeftModule R}
+  : LeftSubmodule M -> Subgroup M
+  := fun N => Build_Subgroup M N _.
+Coercion subgroup_leftsubmodule : LeftSubmodule >-> Subgroup.
+
+Definition subgroup_rightsubmodule {R : Ring} {M : RightModule R}
+  : RightSubmodule M -> Subgroup M
+  := idmap.
+Coercion subgroup_rightsubmodule : RightSubmodule >-> Subgroup.
+
+(** Left submodules inherit the left R-module structure of their parent. *)
+Global Instance isleftmodule_leftsubmodule {R : Ring}
+  {M : LeftModule R} (N : LeftSubmodule M)
+  : IsLeftModule R N.
+Proof.
+  snrapply Build_IsLeftModule.
+  - intros r [n n_in_N].
+    exists (r *L n).
+    by apply lsm_submodule.
+  - intros r [n] [m]; apply path_sigma_hprop.
+    apply lact_left_dist.
+  - intros r s [n]; apply path_sigma_hprop.
+    apply lact_right_dist.
+  - intros r s [n]; apply path_sigma_hprop.
+    apply lact_assoc.
+  - intros [n]; apply path_sigma_hprop.
+    apply lact_unit.
+Defined.
+
+(** Right submodules inherit the right R-module structure of their parent. *)
+Global Instance isrightmodule_rightsubmodule {R : Ring}
+  {M : RightModule R} (N : RightSubmodule M)
+  : IsRightModule R N
+  := isleftmodule_leftsubmodule (R:=rng_op R) N.
+
+(** Any left submodule of a left R-module is a left R-module. *)
+Definition leftmodule_leftsubmodule {R : Ring}
+  {M : LeftModule R} (N : LeftSubmodule M)
+  : LeftModule R
+  := Build_LeftModule R N _.
+Coercion leftmodule_leftsubmodule : LeftSubmodule >-> LeftModule.
+
+(** Any right submodule of a right R-module is a right R-module. *)
+Definition rightmodule_rightsubmodule {R : Ring}
+  {M : RightModule R} (N : RightSubmodule M)
+  : RightModule R
+  := N.
+Coercion rightmodule_rightsubmodule : RightSubmodule >-> RightModule.
+
+(** The submodule criterion. This is a convenient way to build submodules. *)
+Definition Build_IsLeftSubmodule' {R : Ring} {M : LeftModule R} 
+  (H : M -> Type) `{forall x, IsHProp (H x)}
+  (z : H zero)
+  (c : forall r n m, H n -> H m -> H (n + r *L m))
+  : IsLeftSubmodule H.
+Proof.
+  snrapply Build_IsLeftSubmodule.
+  - snrapply Build_IsSubgroup'.
+    + exact _.
+    + exact z.
+    + intros x y hx hy.
+      change (sg_op ?x ?y) with (x + y).
+      pose proof (p := c (-1) x y hx hy).
+      rewrite lm_minus_one in p.
+      exact p.
+  - intros r m hm.
+    rewrite <- (grp_unit_l).
+    by apply c.
+Defined.
+
+Definition Build_IsRightSubmodule' {R : Ring} {M : RightModule R} 
+  (H : M -> Type) `{forall x, IsHProp (H x)}
+  (z : H zero)
+  (c : forall r n m, H n -> H m -> H (n + ract m r))
+  : IsRightSubmodule H
+  := Build_IsLeftSubmodule' (R:=rng_op R) H z c.
+
+Definition Build_LeftSubmodule' {R : Ring} {M : LeftModule R}
+  (H : M -> Type) `{forall x, IsHProp (H x)}
+  (z : H zero)
+  (c : forall r n m, H n -> H m -> H (n + r *L m))
+  : LeftSubmodule M.
+Proof.
+  pose (p := Build_IsLeftSubmodule' H z c).
+  snrapply Build_LeftSubmodule.
+  1: snrapply (Build_Subgroup _ H).
+  2: exact p.
+  rapply ils_issubgroup.
+Defined.
+
+Definition Build_RightSubmodule {R : Ring} {M : RightModule R}
+  (H : M -> Type) `{forall x, IsHProp (H x)}
+  (z : H zero)
+  (c : forall r n m, H n -> H m -> H (n + m *R r))
+  : RightSubmodule M
+  := Build_LeftSubmodule' (R:=rng_op R) H z c.
+
+(** ** R-module homomorphisms *)
+
+(** A left module homomorphism is a group homomorphism that commutes with the left action of R. *)
+Record LeftModuleHomomorphism {R : Ring} (M N : LeftModule R) := {
+  lm_homo_map :> GroupHomomorphism M N;
+  lm_homo_lact : forall r m, lm_homo_map (r *L m) = r *L lm_homo_map m;
+}.
+
+Definition RightModuleHomomorphism {R : Ring} (M N : RightModule R)
+  := LeftModuleHomomorphism (R:=rng_op R) M N.
+
+Definition rm_homo_map {R : Ring} {M N : RightModule R}
+  : RightModuleHomomorphism M N -> GroupHomomorphism M N
+  := lm_homo_map (R:=rng_op R) M N.
+Coercion rm_homo_map : RightModuleHomomorphism >-> GroupHomomorphism.
+
+Definition rm_homo_ract {R : Ring} {M N : RightModule R}
+  (f : RightModuleHomomorphism M N)
+  : forall m r, f (ract m r) = ract (f m) r
+  := fun m r => lm_homo_lact (R:=rng_op R) M N f r m.
+
+Definition lm_homo_id {R : Ring} (M : LeftModule R) : LeftModuleHomomorphism M M.
+Proof.
+  snrapply Build_LeftModuleHomomorphism.
+  - exact grp_homo_id.
+  - reflexivity.
+Defined.
+
+Definition rm_homo_id {R : Ring} (M : RightModule R) : RightModuleHomomorphism M M
+  := lm_homo_id (R:=rng_op R) M.
+
+Definition lm_homo_compose {R : Ring} {M N L : LeftModule R}
+  : LeftModuleHomomorphism N L -> LeftModuleHomomorphism M N
+  -> LeftModuleHomomorphism M L.
+Proof.
+  intros f g.
+  snrapply Build_LeftModuleHomomorphism.
+  - exact (grp_homo_compose f g).
+  - intros r m.
+    rhs_V nrapply lm_homo_lact.
+    apply (ap f).
+    apply lm_homo_lact.
+Defined.
+
+Definition rm_homo_compose {R : Ring} {M N L : RightModule R}
+  : RightModuleHomomorphism N L -> RightModuleHomomorphism M N
+  -> RightModuleHomomorphism M L
+  := lm_homo_compose (R:=rng_op R).
+
+(** Smart constructor for building left module homomorphisms from a map. *)
+Definition Build_LeftModuleHomomorphism' {R : Ring} {M N : LeftModule R}
+  (f : M -> N) (p : forall r x y, f (r *L x + y) = r *L f x + f y)
+  : LeftModuleHomomorphism M N.
+Proof.
+  snrapply Build_LeftModuleHomomorphism.
+  - snrapply Build_GroupHomomorphism.
+    + exact f.
+    + intros x y.
+      rewrite <- (lm_unit (f x)).
+      set (lact 1 (f x)).
+      rewrite <- (lm_unit x).
+      apply p.
+  - intros r m.
+    simpl.
+    rewrite <- (grp_unit_r (lact r m)).
+    rewrite p.
+    rhs_V nrapply grp_unit_r.
+    apply grp_cancelL.
+    specialize (p 1 0 0).
+    rewrite 2 lm_unit in p.
+    apply (grp_cancelL1 (z := f 0)).
+    lhs_V nrapply p.
+    apply ap.
+    apply grp_unit_l.
+Defined.
+
+Definition Build_RightModuleHomomorphism' {R  :Ring} {M N : RightModule R}
+  (f : M -> N) (p : forall r x y, f (x *R r + y) = f x *R r + f y)
+  : RightModuleHomomorphism M N
+  := Build_LeftModuleHomomorphism' (R:=rng_op R) f p.
+
+Record LeftModuleIsomorphism {R : Ring} (M N : LeftModule R) := {
+  lm_iso_map :> LeftModuleHomomorphism M N;
+  isequiv_lm_iso_map :: IsEquiv lm_iso_map;
+}.
+
+Definition RightModuleIsomorphism {R : Ring} (M N : RightModule R)
+  := LeftModuleIsomorphism (R:=rng_op R) M N.
+
+Definition Build_LeftModuleIsomorphism' {R : Ring} (M N : LeftModule R)
+  (f : GroupIsomorphism M N) (p : forall r x, f (r *L x) = r *L f x)
+  : LeftModuleIsomorphism M N.
+Proof.
+  snrapply Build_LeftModuleIsomorphism.
+  - snrapply Build_LeftModuleHomomorphism.
+    + exact f.
+    + exact p.
+  - exact _.
+Defined.
+
+Definition Build_RightModuleIsomorphism' {R : Ring} (M N : RightModule R)
+  (f : GroupIsomorphism M N) (p : forall r x, f (ract x r) = ract (f x) r)
+  : RightModuleIsomorphism M N
+  := Build_LeftModuleIsomorphism' (R:=rng_op R) M N f p.
+
+Definition lm_iso_inverse {R : Ring} {M N : LeftModule R}
+  : LeftModuleIsomorphism M N -> LeftModuleIsomorphism N M.
+Proof.
+  intros f.
+  snrapply Build_LeftModuleIsomorphism.
+  - snrapply Build_LeftModuleHomomorphism'.
+    + exact f^-1.
+    + intros r m n.
+      apply moveR_equiv_V. 
+      rhs nrapply grp_homo_op.
+      symmetry.
+      f_ap.
+      2: apply eisretr.
+      lhs nrapply lm_homo_lact.
+      apply ap.
+      apply eisretr.
+  - exact _.
+Defined.
+
+Definition rm_iso_inverse {R : Ring} {M N : RightModule R}
+  : RightModuleIsomorphism M N -> RightModuleIsomorphism N M
+  := lm_iso_inverse (R:=rng_op R).
+
+(** ** Category of left and right R-modules *)
+
+(** TODO: define as a displayed category over Ring *)
+
+(** *** Category of left R-modules *)
+
+Global Instance isgraph_leftmodule {R : Ring} : IsGraph (LeftModule R)
+  := Build_IsGraph _ LeftModuleHomomorphism.
+
+Global Instance is01cat_leftmodule {R : Ring} : Is01Cat (LeftModule R)
+  := Build_Is01Cat _ _ lm_homo_id (@lm_homo_compose R).
+
+Global Instance is2graph_leftmodule {R : Ring} : Is2Graph (LeftModule R)
+  := fun M N => isgraph_induced (@lm_homo_map R M N).
+
+Global Instance is1cat_leftmodule {R : Ring} : Is1Cat (LeftModule R).
+Proof.
+  snrapply Build_Is1Cat'.
+  - intros M N; rapply is01cat_induced.
+  - intros M N; rapply is0gpd_induced.
+  - intros M N L h.
+    snrapply Build_Is0Functor.
+    intros f g p m.
+    exact (ap h (p m)).
+  - intros M N L f.
+    snrapply Build_Is0Functor.
+    intros g h p m.
+    exact (p (f m)).
+  - simpl; reflexivity.
+  - simpl; reflexivity.
+  - simpl; reflexivity.
+Defined.
+
+Global Instance hasequivs_leftmodule {R : Ring} : HasEquivs (LeftModule R).
+Proof.
+  snrapply Build_HasEquivs.
+  - exact LeftModuleIsomorphism.
+  - intros M N; exact IsEquiv.
+  - intros M N f; exact f.
+  - simpl; exact _.
+  - apply Build_LeftModuleIsomorphism.
+  - reflexivity.
+  - intros M N; apply lm_iso_inverse.
+  - intros M N f; apply eissect.
+  - intros M N f; apply eisretr.
+  - intros M N f g fg gf.
+    exact (isequiv_adjointify f g fg gf).
+Defined.
+
+(** *** Category of right R-modules *)
+
+Global Instance isgraph_rightmodule {R : Ring} : IsGraph (RightModule R)
+  := isgraph_leftmodule (R:=rng_op R).
+
+Global Instance is01cat_rightmodule {R : Ring} : Is01Cat (RightModule R)
+  := is01cat_leftmodule (R:=rng_op R).
+
+Global Instance is2graph_rightmodule {R : Ring} : Is2Graph (RightModule R)
+  := is2graph_leftmodule (R:=rng_op R).
+
+Global Instance is1cat_rightmodule {R : Ring} : Is1Cat (RightModule R)
+  := is1cat_leftmodule (R:=rng_op R).
+
+Global Instance hasequivs_rightmodule {R : Ring} : HasEquivs (RightModule R)
+  := hasequivs_leftmodule (R:=rng_op R).
+
+(** ** Kernel of module homomorphism *)
+
+Global Instance isleftsubmodule_grp_kernel {R : Ring}
+  {M N : LeftModule R} (f : M $-> N)
+  : IsLeftSubmodule (grp_kernel f).
+Proof.
+  srapply Build_IsLeftSubmodule.
+  intros r m n.
+  lhs nrapply lm_homo_lact.
+  rhs_V nrapply (lm_zero_r r).
+  apply ap.
+  exact n.
+Defined.
+
+Global Instance isrightsubmodule_grp_kernel {R : Ring}
+  {M N : RightModule R} (f : M $-> N)
+  : IsRightSubmodule (grp_kernel f)
+  := isleftsubmodule_grp_kernel (R:=rng_op R) f.
+
+Definition lm_kernel {R : Ring} {M N : LeftModule R} (f : M $-> N)
+  : LeftSubmodule M
+  := Build_LeftSubmodule _ _ (grp_kernel f) _.
+
+Definition rm_kernel {R : Ring} {M N : RightModule R} (f : M $-> N)
+  : RightSubmodule M
+  := lm_kernel (R:=rng_op R) f.
+
+(** ** Image of module homomorphism *)
+
+Global Instance isleftsubmodule_grp_image {R : Ring}
+  {M N : LeftModule R} (f : M $-> N)
+  : IsLeftSubmodule (grp_image f).
+Proof.
+  srapply Build_IsLeftSubmodule.
+  intros r m; apply Trunc_functor; intros [n p].
+  exists (r *L n).
+  lhs nrapply lm_homo_lact.
+  apply ap.
+  exact p.
+Defined.
+
+Global Instance isrightsubmodule_grp_image {R : Ring}
+  {M N : RightModule R} (f : M $-> N)
+  : IsRightSubmodule (grp_image f)
+  := isleftsubmodule_grp_image (R:=rng_op R) f.
+
+Definition lm_image {R : Ring} {M N : LeftModule R} (f : M $-> N)
+  : LeftSubmodule N
+  := Build_LeftSubmodule _ _ (grp_image f) _.
+
+Definition rm_image {R : Ring} {M N : RightModule R} (f : M $-> N)
+  : RightSubmodule N
+  := lm_image (R:=rng_op R) f.
+
+(** ** Quotient Modules *)
+
+(** The quotient abelian group of a module and a submodule has a natural ring action. *)
+Global Instance isleftmodule_quotientabgroup {R : Ring}
+  (M : LeftModule R) (N : LeftSubmodule M)
+  : IsLeftModule R (QuotientAbGroup M N).
+Proof.
+  snrapply Build_IsLeftModule.
+  - intros r.
+    snrapply quotient_abgroup_rec.
+    + refine (grp_quotient_map $o _). 
+      snrapply Build_GroupHomomorphism.
+      * exact (lact r).
+      * intros x y.
+        apply lm_dist_l.
+    + intros n Nn; simpl.
+      apply qglue.
+      apply issubgroup_in_inv_op.
+      2: apply issubgroup_in_unit.
+      by apply is_left_submodule.
+  - intros r m n; revert m.
+    snrapply Quotient_ind_hprop; [exact _ | intros m; revert n].
+    snrapply Quotient_ind_hprop; [exact _ | intros n; simpl].
+    rapply ap.
+    apply lm_dist_l.
+  - intros r s.
+    snrapply Quotient_ind_hprop; [exact _| intros m; simpl].
+    rapply ap.
+    apply lm_dist_r.
+  - intros r s.
+    snrapply Quotient_ind_hprop; [exact _| intros m; simpl].
+    rapply ap.
+    apply lm_assoc.
+  - snrapply Quotient_ind_hprop; [exact _| intros m; simpl].
+    rapply ap.
+    apply lm_unit.
+Defined.
+
+Global Instance isrightmodule_quotientabgroup {R : Ring}
+  (M : RightModule R) (N : RightSubmodule M)
+  : IsRightModule R (QuotientAbGroup M N)
+  := isleftmodule_quotientabgroup (R:=rng_op R) M N.
+
+(** We can therefore form the quotient module of a module by its submodule. *)
+Definition QuotientLeftModule {R : Ring} (M : LeftModule R) (N : LeftSubmodule M)
+  : LeftModule R
+  := Build_LeftModule R (QuotientAbGroup M N) _.
+
+Definition QuotientRightModule {R : Ring} (M : RightModule R) (N : RightSubmodule M)
+  : RightModule R
+  := QuotientLeftModule (R:=rng_op R) M N.
+
+Infix "/" := QuotientLeftModule : module_scope.
+
+(** TODO: Notation for right module quotient? *)
+  
+(** ** First Isomorphism Theorem *)
+
+Local Open Scope module_scope.
+Local Open Scope wc_iso_scope.
+
+Definition lm_first_iso `{Funext} {R : Ring} {M N : LeftModule R} (f : M $-> N)
+  : M / lm_kernel f ≅ lm_image f.
+Proof.
+  snrapply Build_LeftModuleIsomorphism'.
+  1: rapply abgroup_first_iso.
+  intros r.
+  srapply Quotient_ind_hprop; intros m.
+  apply path_sigma_hprop; simpl.
+  apply lm_homo_lact.
+Defined.
+
+Definition rm_first_iso `{Funext} {R : Ring} {M N : RightModule R} (f : M $-> N)
+  : QuotientRightModule M (rm_kernel f) ≅ rm_image f
+  := lm_first_iso (R:=rng_op R) f.
+
+(** ** Direct products *)
+
+(** TODO: generalise to biproducts *)
+(** The direct product of modules *)
+Definition lm_prod {R : Ring} : LeftModule R -> LeftModule R -> LeftModule R.
+Proof.
+  intros M N.
+  snrapply (Build_LeftModule R (ab_biprod M N)).
+  snrapply Build_IsLeftModule.
+  - intros r.
+    apply functor_prod; exact (lact r).
+  - intros r m n.
+    apply path_prod; apply lm_dist_l.
+  - intros r m n.
+    apply path_prod; apply lm_dist_r.
+  - intros r s m.
+    apply path_prod; apply lm_assoc.
+  - intros r.
+    apply path_prod; apply lm_unit.
+Defined.
+
+Definition rm_prod {R : Ring} : RightModule R -> RightModule R -> RightModule R
+  := lm_prod (R:=rng_op R).
+
+Definition lm_prod_fst {R : Ring} {M N : LeftModule R} : lm_prod M N $-> M.
+Proof.
+  snrapply Build_LeftModuleHomomorphism.
+  - apply grp_prod_pr1.
+  - reflexivity.
+Defined.
+
+Definition rm_prod_fst {R : Ring} {M N : RightModule R} : rm_prod M N $-> M
+  := lm_prod_fst (R:=rng_op R).
+
+Definition lm_prod_snd {R : Ring} {M N : LeftModule R} : lm_prod M N $-> N.
+Proof.
+  snrapply Build_LeftModuleHomomorphism.
+  - apply grp_prod_pr2.
+  - reflexivity.
+Defined.
+
+Definition rm_prod_snd {R : Ring} {M N : RightModule R} : rm_prod M N $-> N
+  := lm_prod_snd (R:=rng_op R).
+
+Definition lm_prod_corec {R : Ring} {M N : LeftModule R} (L : LeftModule R)
+  (f : L $-> M) (g : L $-> N)
+  : L $-> lm_prod M N.
+Proof.
+  snrapply Build_LeftModuleHomomorphism.
+  - apply (grp_prod_corec f g).
+  - intros r l.
+    apply path_prod; apply lm_homo_lact.
+Defined.
+
+Definition rm_prod_corec {R : Ring} {M N : RightModule R} (R' : RightModule R)
+  (f : R' $-> M) (g : R' $-> N)
+  : R' $-> rm_prod M N
+  := lm_prod_corec (R:=rng_op R) R' f g.
+
+Global Instance hasbinaryproducts_leftmodule {R : Ring}
+  : HasBinaryProducts (LeftModule R).
+Proof.
+  intros M N.
+  snrapply Build_BinaryProduct.
+  - exact (lm_prod M N).
+  - exact lm_prod_fst.
+  - exact lm_prod_snd.
+  - exact lm_prod_corec.
+  - cbn; reflexivity.
+  - cbn; reflexivity.
+  - intros L f g p q a.
+    exact (path_prod' (p a) (q a)).
+Defined.
+
+Global Instance hasbinaryproducts_rightmodule {R : Ring}
+  : HasBinaryProducts (RightModule R)
+  := hasbinaryproducts_leftmodule (R:=rng_op R).
+
+(** ** Finite Sums *)
+
+(** Left scalar multplication distributes over finite sums of left module elements. *)
+Definition lm_sum_dist_l {R : Ring} (M : LeftModule R) (n : nat)
+  (f : forall k, (k < n)%nat -> M) (r : R)
+  : r *L ab_sum n f = ab_sum n (fun k Hk => r *L f k Hk).
+Proof.
+  induction n as [|n IHn].
+  1: apply lm_zero_r.
+  lhs nrapply lm_dist_l; simpl; f_ap.
+Defined.
+
+(** Right scalar multiplication distributes over finite sums of right module elements. *)
+Definition rm_sum_dist_r {R : Ring} (M : RightModule R) (n : nat)
+  (f : forall k, (k < n)%nat -> M) (r : R)
+  : ab_sum n f *R r = ab_sum n (fun k Hk => f k Hk *R r)
+  := lm_sum_dist_l (R:=rng_op R) M n f r.
+
+(** Left module elements distribute over finite sums of scalars. *)
+Definition lm_sum_dist_r {R : Ring} (M : LeftModule R) (n : nat)
+  (f : forall k, (k < n)%nat -> R) (x : M)
+  : ab_sum n f *L x = ab_sum n (fun k Hk => f k Hk *L x).
+Proof.
+  induction n as [|n IHn].
+  1: apply lm_zero_l.
+  lhs nrapply lm_dist_r; simpl; f_ap.
+Defined.
+
+(** Right module elements distribute over finite sums of scalar. *)
+Definition rm_sum_dist_l {R : Ring} (M : RightModule R) (n : nat)
+  (f : forall k, (k < n)%nat -> R) (x : M)
+  : x *R ab_sum n f = ab_sum n (fun k Hk => x *R f k Hk)
+  := lm_sum_dist_r (R:=rng_op R) M n f x.
diff --git a/theories/Algebra/Rings/QuotientRing.v b/theories/Algebra/Rings/QuotientRing.v
index db8545b349b..514c3a1a99f 100644
--- a/theories/Algebra/Rings/QuotientRing.v
+++ b/theories/Algebra/Rings/QuotientRing.v
@@ -1,67 +1,52 @@
-Require Import WildCat.
+Require Import WildCat.Core WildCat.Equiv.
 Require Import Algebra.Congruence.
 Require Import Algebra.AbGroups.
 Require Import Classes.interfaces.abstract_algebra.
-Require Import Algebra.Rings.CRing.
+Require Import Algebra.Rings.Ring.
 Require Import Algebra.Rings.Ideal.
 
-(** In this file we define the quotient of a commutative ring by an ideal *)
+(** * Quotient Rings *)
+
+(** In this file we define the quotient of a ring by an ideal. *)
 
 Import Ideal.Notation.
 Local Open Scope ring_scope.
 Local Open Scope wc_iso_scope.
 
-(** In this file we define the quotient of a commutative ring by an ideal and prove some basic facts. *)
-
 Section QuotientRing.
 
-  Context (R : CRing) (I : Ideal R).
+  Context (R : Ring) (I : Ideal R).
 
   Instance plus_quotient_group : Plus (QuotientAbGroup R I) := group_sgop.
 
   Instance iscong_mult_incosetL
-    : @IsCongruence R cring_mult (in_cosetL I).
+    : @IsCongruence R ring_mult (in_cosetL I).
   Proof.
     snrapply Build_IsCongruence.
     intros x x' y y' p q.
     change (I ( - (x * y) + (x' * y'))).
-    change (I (-x + x')) in p.
-    change (I (-y + y')) in q.
-    rewrite <- (left_identity (op:=(+)) (x' * y') : 0 + (x' * y') = x' * y').
-    rewrite <- (right_inverse (op:=(+)) (x' * y) : (x' * y) - (x' * y) = 0).
-    rewrite 2 simple_associativity.
-    rewrite negate_mult_distr_l.
-    rewrite <- simple_distribute_r.
-    rewrite <- simple_associativity.
-    rewrite negate_mult_distr_r.
-    rewrite <- simple_distribute_l.
+    rewrite <- (rng_plus_zero_l (x' * y')).
+    rewrite <- (rng_plus_negate_r (x' * y)).
+    rewrite 2 rng_plus_assoc.
+    rewrite <- rng_mult_negate_l.
+    rewrite <- rng_dist_r.
+    rewrite <- rng_plus_assoc.
+    rewrite <- rng_mult_negate_r.
+    rewrite <- rng_dist_l.
     rapply subgroup_in_op.
-    1: rewrite (commutativity _ y).
-    all: by rapply isideal.
+    - by rapply isrightideal.
+    - by rapply isleftideal.
   Defined.
 
   Instance mult_quotient_group : Mult (QuotientAbGroup R I).
   Proof.
-    intro x.
-    srapply Quotient_rec.
-    { intro y; revert x.
-      srapply Quotient_rec.
-      { intro x.
-        apply class_of.
-        exact (x * y). }
-      intros x x' p.
+    srapply Quotient_rec2.
+    - exact (fun x y => class_of _ (x * y)).
+    - intros x x' p y y' q; simpl.
       apply qglue.
-      by rapply iscong. }
-    intros y y' q.
-    revert x.
-    srapply Quotient_ind_hprop.
-    intro x.
-    simpl.
-    apply qglue.
-    by rapply iscong.
+      by rapply iscong.
   Defined.
 
-  Instance zero_quotient_abgroup : Zero (QuotientAbGroup R I) := class_of _ zero.
   Instance one_quotient_abgroup : One (QuotientAbGroup R I) := class_of _ one.
 
   Instance isring_quotient_abgroup : IsRing (QuotientAbGroup R I).
@@ -71,10 +56,7 @@ Section QuotientRing.
     1: repeat split.
     1: exact _.
     (** Associativity follows from the underlying operation *)
-    { intros x y.
-      snrapply Quotient_ind_hprop; [exact _ | intro z; revert y].
-      snrapply Quotient_ind_hprop; [exact _ | intro y; revert x].
-      snrapply Quotient_ind_hprop; [exact _ | intro x ].
+    { srapply Quotient_ind3_hprop; intros x y z.
       unfold sg_op, mult_is_sg_op, mult_quotient_group; simpl.
       apply ap.
       apply associativity. }
@@ -84,41 +66,36 @@ Section QuotientRing.
     1-2: apply ap.
     1: apply left_identity.
     1: apply right_identity.
-    (** Commutativity also follows *)
-    { intros x.
-      snrapply Quotient_ind_hprop; [exact _ | intro y; revert x].
-      snrapply Quotient_ind_hprop; [exact _ | intro x].
-      unfold sg_op, mult_is_sg_op, mult_quotient_group; simpl.
-      apply ap.
-      apply commutativity. }
     (** Finally distributivity also follows *)
-    { intros x y.
-      snrapply Quotient_ind_hprop; [exact _ | intro z; revert y].
-      snrapply Quotient_ind_hprop; [exact _ | intro y; revert x].
-      snrapply Quotient_ind_hprop; [exact _ | intro x ].
+    { srapply Quotient_ind3_hprop; intros x y z.
       unfold sg_op, mult_is_sg_op, mult_quotient_group,
         plus, mult, plus_quotient_group; simpl.
       apply ap.
       apply simple_distribute_l. }
+    { srapply Quotient_ind3_hprop; intros x y z.
+      unfold sg_op, mult_is_sg_op, mult_quotient_group,
+        plus, mult, plus_quotient_group; simpl.
+      apply ap.
+      apply simple_distribute_r. }
   Defined.
 
-  Definition QuotientRing : CRing 
-    := Build_CRing (QuotientAbGroup R I) _ _ _ _ _ _.
+  Definition QuotientRing : Ring 
+    := Build_Ring (QuotientAbGroup R I) _ _ _ _ _.
 
 End QuotientRing.
 
 Infix "/" := QuotientRing : ring_scope.
 
 (** Quotient map *)
-Definition rng_quotient_map {R : CRing} (I : Ideal R)
-  : CRingHomomorphism R (R / I).
+Definition rng_quotient_map {R : Ring} (I : Ideal R)
+  : RingHomomorphism R (R / I).
 Proof.
-  snrapply Build_CRingHomomorphism'.
+  snrapply Build_RingHomomorphism'.
   1: rapply grp_quotient_map.
   repeat split.
 Defined.
 
-Global Instance issurj_rng_quotient_map {R : CRing} (I : Ideal R)
+Global Instance issurj_rng_quotient_map {R : Ring} (I : Ideal R)
   : IsSurjection (rng_quotient_map I).
 Proof.
   exact _.
@@ -127,7 +104,7 @@ Defined.
 (** *** Specialized induction principles *)
 
 (** We provide some specialized induction principes for [QuotientRing] that require cleaner hypotheses than the ones given by [Quotient_ind]. *)
-Definition QuotientRing_ind {R : CRing} {I : Ideal R} (P : R / I -> Type)
+Definition QuotientRing_ind {R : Ring} {I : Ideal R} (P : R / I -> Type)
   `{forall x, IsHSet (P x)}
   (c : forall (x : R), P (rng_quotient_map I x))
   (g : forall (x y : R) (h : I (- x + y)), qglue h # c x = c y)
@@ -135,23 +112,40 @@ Definition QuotientRing_ind {R : CRing} {I : Ideal R} (P : R / I -> Type)
   := Quotient_ind _ P c g.
 
 (** And a version eliminating into hprops. This one is especially useful. *)
-Definition QuotientRing_ind_hprop {R : CRing} {I : Ideal R} (P : R / I -> Type)
+Definition QuotientRing_ind_hprop {R : Ring} {I : Ideal R} (P : R / I -> Type)
   `{forall x, IsHProp (P x)} (c : forall (x : R), P (rng_quotient_map I x))
   : forall (r : R / I), P r
   := Quotient_ind_hprop _ P c.
 
-(** ** Quotient thoery *)
+Definition QuotientRing_ind2_hprop {R : Ring} {I : Ideal R} (P : R / I -> R / I -> Type)
+  `{forall x y, IsHProp (P x y)}
+  (c : forall (x y : R), P (rng_quotient_map I x) (rng_quotient_map I y))
+  : forall (r s : R / I), P r s
+  := Quotient_ind2_hprop _ P c.
+
+Definition QuotientRing_rec {R : Ring} {I : Ideal R} (S : Ring)
+  (f : R $-> S) (H : forall x, I x -> f x = 0) 
+  : R / I $-> S.
+Proof.
+  snrapply Build_RingHomomorphism'.
+  - snrapply (grp_quotient_rec _ _ f).
+    exact H.
+  - split.
+    + srapply QuotientRing_ind2_hprop.
+      nrapply rng_homo_mult.
+    + nrapply rng_homo_one.
+Defined.
+
+(** ** Quotient theory *)
 
 (** First isomorphism theorem for commutative rings *)
-Definition rng_first_iso `{Funext} {A B : CRing} (f : A $-> B)
+Definition rng_first_iso `{Funext} {A B : Ring} (f : A $-> B)
   : A / ideal_kernel f ≅ rng_image f.
 Proof.
-  snrapply Build_CRingIsomorphism''.
+  snrapply Build_RingIsomorphism''.
   1: rapply abgroup_first_iso.
   split.
-  { intros x y.
-    revert y; srapply QuotientRing_ind_hprop; intros y.
-    revert x; srapply QuotientRing_ind_hprop; intros x.
+  { srapply QuotientRing_ind2_hprop; intros x y.
     srapply path_sigma_hprop.
     exact (rng_homo_mult _ _ _). }
   srapply path_sigma_hprop.
@@ -159,20 +153,16 @@ Proof.
 Defined.
 
 (** Invariance of equal ideals *)
-Lemma rng_quotient_invar {R : CRing} {I J : Ideal R} (p : (I ↔ J)%ideal)
+Lemma rng_quotient_invar {R : Ring} {I J : Ideal R} (p : (I ↔ J)%ideal)
   : R / I ≅ R / J.
 Proof.
-  snrapply Build_CRingIsomorphism'.
+  snrapply Build_RingIsomorphism'.
   { srapply equiv_quotient_functor'.
     1: exact equiv_idmap.
     intros x y; cbn.
     apply p. }
   repeat split.
-  1,2: intros x; simpl.
-  1,2: srapply QuotientRing_ind_hprop.
-  1,2: intros y; revert x.
-  1,2: srapply QuotientRing_ind_hprop.
-  1,2: intros x; rapply qglue.
+  1,2: srapply Quotient_ind2_hprop; intros x y; rapply qglue.
   1: change (J ( - (x + y) + (x + y))).
   2: change (J (- ( x * y) + (x * y))).
   1,2: rewrite rng_plus_negate_l.
@@ -180,7 +170,7 @@ Proof.
 Defined.
 
 (** We phrase the first ring isomorphism theroem in a slightly differnt way so that it is easier to use. This form specifically asks for a surjective map *)
-Definition rng_first_iso' `{Funext} {A B : CRing} (f : A $-> B)
+Definition rng_first_iso' `{Funext} {A B : Ring} (f : A $-> B)
   (issurj_f : IsSurjection f)
   (I : Ideal A) (p : (I ↔ ideal_kernel f)%ideal)
   : A / I ≅ B.
diff --git a/theories/Algebra/Rings/Ring.v b/theories/Algebra/Rings/Ring.v
new file mode 100644
index 00000000000..da5d0134355
--- /dev/null
+++ b/theories/Algebra/Rings/Ring.v
@@ -0,0 +1,911 @@
+Require Import WildCat.
+Require Import Spaces.Nat.Core Spaces.Nat.Arithmetic.
+(* Some of the material in abstract_algebra and canonical names could be selectively exported to the user, as is done in Groups/Group.v. *)
+Require Import Classes.interfaces.abstract_algebra.
+Require Import Algebra.Groups.Group Algebra.Groups.Subgroup.
+Require Export Algebra.AbGroups.
+Require Export Classes.theory.rings.
+Require Import Modalities.ReflectiveSubuniverse.
+
+(** * Rings *)
+
+Declare Scope ring_scope.
+
+Local Open Scope ring_scope.
+(** We want to print equivalences as [≅]. *)
+Local Open Scope wc_iso_scope.
+
+(** A ring consists of the following data: *)
+Record Ring := Build_Ring' {
+  (** An underlying abelian group. *)
+  ring_abgroup :> AbGroup;
+  (** A multiplication operation. *)
+  ring_mult :: Mult ring_abgroup;
+  (** A multiplicative identity called [one]. *)
+  ring_one :: One ring_abgroup;
+  (** Such that all they all satisfy the axioms of a ring. *)
+  ring_isring :: IsRing ring_abgroup;
+  (** This field only exists so that opposite rings are definitionally involutive and can safely be ignored. *)
+  ring_mult_assoc_opp : forall z y x, (x * y) * z = x * (y * z);
+}.
+
+
+Arguments ring_mult {R} : rename.
+Arguments ring_one {R} : rename.
+Arguments ring_isring {R} : rename.
+
+Definition issig_Ring : _ <~> Ring := ltac:(issig).
+
+Global Instance ring_plus {R : Ring} : Plus R := plus_abgroup (ring_abgroup R).
+Global Instance ring_zero {R : Ring} : Zero R := zero_abgroup (ring_abgroup R).
+Global Instance ring_negate {R : Ring} : Negate R := negate_abgroup (ring_abgroup R).
+
+(** A ring homomorphism between rings is a map of the underlying type and a proof that this map is a ring homomorphism. *)
+Record RingHomomorphism (A B : Ring) := {
+  rng_homo_map :> A -> B;
+  rng_homo_ishomo :: IsSemiRingPreserving rng_homo_map;
+}.
+
+Arguments Build_RingHomomorphism {_ _} _ _.
+
+Definition issig_RingHomomorphism (A B : Ring)
+  : _ <~> RingHomomorphism A B
+  := ltac:(issig).
+
+Definition equiv_path_ringhomomorphism `{Funext} {A B : Ring}
+  {f g : RingHomomorphism A B} : f == g <~> f = g.
+Proof.
+  refine ((equiv_ap (issig_RingHomomorphism A B)^-1 _ _)^-1 oE _).
+  refine (equiv_path_sigma_hprop _ _ oE _).
+  apply equiv_path_forall.
+Defined.
+
+Definition rng_homo_id (A : Ring) : RingHomomorphism A A
+  := Build_RingHomomorphism idmap (Build_IsSemiRingPreserving _ _ _).
+
+Definition rng_homo_compose {A B C : Ring}
+  (f : RingHomomorphism B C) (g : RingHomomorphism A B)
+  : RingHomomorphism A C.
+Proof.
+  snrapply Build_RingHomomorphism.
+  1: exact (f o g).
+  rapply compose_sr_morphism.
+Defined.
+
+(** ** Ring laws *)
+
+Section RingLaws.
+
+  (** Many of these ring laws have already been proven. But we give them names here so that they are easy to find and use. *)
+
+  Context {A : Ring} (x y z : A).
+
+  Definition rng_dist_l : x * (y + z) = x * y + x * z := simple_distribute_l _ _ _.
+  Definition rng_dist_r : (x + y) * z = x * z + y * z := simple_distribute_r _ _ _.
+  Definition rng_plus_zero_l : 0 + x = x := left_identity _.
+  Definition rng_plus_zero_r : x + 0 = x := right_identity _.
+  Definition rng_plus_negate_l : (- x) + x = 0 := left_inverse _.
+  Definition rng_plus_negate_r : x + (- x) = 0 := right_inverse _.
+
+  Definition rng_plus_comm : x + y = y + x := commutativity x y.
+  Definition rng_plus_assoc : x + (y + z) = (x + y) + z := simple_associativity x y z.
+  Definition rng_mult_assoc : x * (y * z) = (x * y) * z := simple_associativity x y z.
+
+  Definition rng_negate_negate : - (- x) = x := groups.negate_involutive _.
+  Definition rng_negate_zero : - (0 : A) = 0 := groups.negate_mon_unit.
+  Definition rng_negate_plus : - (x + y) = - x - y := negate_plus_distr _ _.
+
+  Definition rng_mult_one_l : 1 * x = x := left_identity _.
+  Definition rng_mult_one_r : x * 1 = x := right_identity _.
+  Definition rng_mult_zero_l : 0 * x = 0 := left_absorb _.
+  Definition rng_mult_zero_r : x * 0 = 0 := right_absorb _.
+  Definition rng_mult_negate : -1 * x = - x := (negate_mult_l _)^.
+  Definition rng_mult_negate_negate : -x * -y = x * y := negate_mult_negate _ _.
+  Definition rng_mult_negate_l : -x * y = -(x * y) := inverse (negate_mult_distr_l _ _).
+  Definition rng_mult_negate_r : x * -y = -(x * y) := inverse (negate_mult_distr_r _ _).
+
+End RingLaws.
+
+Definition rng_dist_l_negate {A : Ring} (x y z : A)
+  : x * (y - z) = x * y - x * z.
+Proof.
+  lhs nrapply rng_dist_l.
+  nrapply ap.
+  nrapply rng_mult_negate_r.
+Defined.
+
+Definition rng_dist_r_negate {A : Ring} (x y z : A)
+  : (x - y) * z = x * z - y * z.
+Proof.
+  lhs nrapply rng_dist_r.
+  nrapply ap.
+  nrapply rng_mult_negate_l.
+Defined.
+
+Section RingHomoLaws.
+
+  Context {A B : Ring} (f : RingHomomorphism A B) (x y : A).
+
+  Definition rng_homo_plus : f (x + y) = f x + f y := preserves_plus x y.
+  Definition rng_homo_mult : f (x * y) = f x * f y := preserves_mult x y.
+  Definition rng_homo_zero : f 0 = 0 := preserves_0.
+  Definition rng_homo_one  : f 1 = 1 := preserves_1.
+  Definition rng_homo_negate : f (-x) = -(f x) := preserves_negate x.
+
+  Definition rng_homo_minus_one : f (-1) = -1
+    := preserves_negate 1%mc @ ap negate preserves_1.
+
+End RingHomoLaws.
+
+(** Isomorphisms of commutative rings *)
+Record RingIsomorphism (A B : Ring) := {
+  rng_iso_homo : RingHomomorphism A B ;
+  isequiv_rng_iso_homo : IsEquiv rng_iso_homo ;
+}.
+
+Arguments rng_iso_homo {_ _ }.
+Coercion rng_iso_homo : RingIsomorphism >-> RingHomomorphism.
+Global Existing Instance isequiv_rng_iso_homo.
+
+Definition issig_RingIsomorphism {A B : Ring}
+  : _ <~> RingIsomorphism A B := ltac:(issig).
+
+(** We can construct a ring isomorphism from an equivalence that preserves addition and multiplication. *)
+Definition Build_RingIsomorphism' (A B : Ring) (e : A <~> B)
+  `{!IsSemiRingPreserving e}
+  : RingIsomorphism A B
+  := Build_RingIsomorphism A B (Build_RingHomomorphism e _) _.
+
+(** The inverse of a Ring isomorphism *)
+Definition rng_iso_inverse {A B : Ring}
+  : RingIsomorphism A B -> RingIsomorphism B A.
+Proof.
+  intros [f e].
+  snrapply Build_RingIsomorphism.
+  { snrapply Build_RingHomomorphism.
+    1: exact f^-1.
+    exact _. }
+  exact _.
+Defined.
+
+(** Ring isomorphisms are a reflexive relation *)
+Global Instance reflexive_ringisomorphism : Reflexive RingIsomorphism
+  := fun x => Build_RingIsomorphism _ _ (rng_homo_id x) _.
+
+(** Ring isomorphisms are a symmetric relation *)
+Global Instance symmetry_ringisomorphism : Symmetric RingIsomorphism
+  := fun x y => rng_iso_inverse.
+
+(** Ring isomorphisms are a transitive relation *)
+Global Instance transitive_ringisomorphism : Transitive RingIsomorphism
+  := fun x y z f g => Build_RingIsomorphism _ _ (rng_homo_compose g f) _.
+
+(** Underlying group homomorphism of a ring homomorphism *)
+Definition grp_homo_rng_homo {R S : Ring}
+  : RingHomomorphism R S -> GroupHomomorphism R S
+  := fun f => @Build_GroupHomomorphism R S f _.
+
+Coercion grp_homo_rng_homo : RingHomomorphism >-> GroupHomomorphism.
+
+(** We can construct a ring homomorphism from a group homomorphism that preserves multiplication *)
+Definition Build_RingHomomorphism' (A B : Ring) (map : GroupHomomorphism A B)
+  {H : IsMonoidPreserving (Aop:=ring_mult) (Bop:=ring_mult)
+    (Aunit:=one) (Bunit:=one) map}
+  : RingHomomorphism A B
+  := Build_RingHomomorphism map
+      (Build_IsSemiRingPreserving _ (ismonoidpreserving_grp_homo map) H).
+
+(** We can construct a ring isomorphism from a group isomorphism that preserves multiplication *)
+Definition Build_RingIsomorphism'' (A B : Ring) (e : GroupIsomorphism A B)
+  {H : IsMonoidPreserving (Aop:=ring_mult) (Bop:=ring_mult) (Aunit:=one) (Bunit:=one) e}
+  : RingIsomorphism A B
+  := @Build_RingIsomorphism' A B e (Build_IsSemiRingPreserving e _ H).
+
+(** Here is an alternative way to build a commutative ring using the underlying abelian group. *)
+Definition Build_Ring (R : AbGroup)
+  `(Mult R, One R, LeftDistribute R mult (@group_sgop R), RightDistribute R mult (@group_sgop R))
+  (iscomm : @IsMonoid R mult one)
+  : Ring
+  := Build_Ring' R _ _ (Build_IsRing _ _ _  _ _) (fun z y x => (associativity x y z)^).
+
+(** Scalar multiplication on the left is a group homomorphism. *)
+Definition grp_homo_rng_left_mult {R : Ring} (r : R)
+  : GroupHomomorphism R R
+  := @Build_GroupHomomorphism R R (fun s => r * s) (rng_dist_l r).
+
+(** Scalar multiplication on the right is a group homomorphism. *)
+Definition grp_homo_rng_right_mult {R : Ring} (r : R)
+  : GroupHomomorphism R R
+  := @Build_GroupHomomorphism R R (fun s => s * r) (fun x y => rng_dist_r x y r).
+
+(** ** Ring movement lemmas *)
+
+Section RingMovement.
+
+  (** We adopt a similar naming convention to the [moveR_equiv] style lemmas that can be found in Types.Paths. *)
+
+  Context {R : Ring} {x y z : R}.
+
+  Definition rng_moveL_Mr : - y + x = z <~> x = y + z := @grp_moveL_Mg R x y z.
+  Definition rng_moveL_rM : x + - z = y <~> x = y + z := @grp_moveL_gM R x y z.
+  Definition rng_moveR_Mr : y = - x + z <~> x + y = z := @grp_moveR_Mg R x y z.
+  Definition rng_moveR_rM : x = z + - y <~> x + y = z := @grp_moveR_gM R x y z.
+
+  Definition rng_moveL_Vr : x + y = z <~> y = - x + z := @grp_moveL_Vg R x y z.
+  Definition rng_moveL_rV : x + y = z <~> x = z + - y := @grp_moveL_gV R x y z.
+  Definition rng_moveR_Vr : x = y + z <~> - y + x = z := @grp_moveR_Vg R x y z.
+  Definition rng_moveR_rV : x = y + z <~> x + - z = y := @grp_moveR_gV R x y z.
+
+  Definition rng_moveL_M0 : - y + x = 0 <~> x = y := @grp_moveL_M1 R x y.
+  Definition rng_moveL_0M :	x + - y = 0 <~> x = y := @grp_moveL_1M R x y.
+  Definition rng_moveR_M0 : 0 = - x + y <~> x = y := @grp_moveR_M1 R x y.
+  Definition rng_moveR_0M : 0 = y + - x <~> x = y := @grp_moveR_1M R x y.
+
+  (** TODO: Movement laws about mult *)
+
+End RingMovement.
+
+(** ** Wild category of rings *)
+
+Global Instance isgraph_ring : IsGraph Ring
+  := Build_IsGraph _ RingHomomorphism.
+
+Global Instance is01cat_ring : Is01Cat Ring
+  := Build_Is01Cat _ _ rng_homo_id (@rng_homo_compose).
+
+Global Instance is2graph_ring : Is2Graph Ring
+  := fun A B => isgraph_induced (@rng_homo_map A B : _ -> (group_type _ $-> _)).
+
+Global Instance is01cat_ringhomomorphism {A B : Ring} : Is01Cat (A $-> B)
+  := is01cat_induced (@rng_homo_map A B).
+
+Global Instance is0gpd_ringhomomorphism {A B : Ring} : Is0Gpd (A $-> B)
+  := is0gpd_induced (@rng_homo_map A B).
+
+Global Instance is0functor_postcomp_ringhomomorphism {A B C : Ring} (h : B $-> C)
+  : Is0Functor (@cat_postcomp Ring _ _ A B C h).
+Proof.
+  apply Build_Is0Functor.
+  intros [f ?] [g ?] p a ; exact (ap h (p a)).
+Defined.
+
+Global Instance is0functor_precomp_ringhomomorphism
+       {A B C : Ring} (h : A $-> B)
+  : Is0Functor (@cat_precomp Ring _ _ A B C h).
+Proof.
+  apply Build_Is0Functor.
+  intros [f ?] [g ?] p a ; exact (p (h a)).
+Defined.
+
+(** Ring forms a 1-category. *)
+Global Instance is1cat_ring : Is1Cat Ring.
+Proof.
+  by rapply Build_Is1Cat.
+Defined.
+
+Global Instance hasmorext_ring `{Funext} : HasMorExt Ring.
+Proof.
+  srapply Build_HasMorExt.
+  intros A B f g; cbn in *.
+  snrapply @isequiv_homotopic.
+  1: exact (equiv_path_ringhomomorphism^-1%equiv).
+  1: exact _.
+  intros []; reflexivity. 
+Defined.
+
+Global Instance hasequivs_ring : HasEquivs Ring.
+Proof.
+  unshelve econstructor.
+  + exact RingIsomorphism.
+  + exact (fun G H f => IsEquiv f).
+  + intros G H f; exact f.
+  + exact Build_RingIsomorphism.
+  + intros G H; exact rng_iso_inverse.
+  + cbn; exact _.
+  + reflexivity.
+  + intros ????; apply eissect.
+  + intros ????; apply eisretr.
+  + intros G H f g p q.
+    exact (isequiv_adjointify f g p q).
+Defined.
+
+(** ** Subrings *)
+
+(** TODO: factor out this definition as a submonoid *)
+(** A subring is a subgorup of the underlying abelian group of a ring that is closed under multiplication and contains [1]. *)
+Class IsSubring {R : Ring} (S : R -> Type) := {
+  issubring_issubgroup :: IsSubgroup S;
+  issubring_mult {x y} : S x -> S y -> S (x * y);
+  issubring_one : S 1;
+}.
+
+Definition issig_IsSubring {R : Ring} (S : R -> Type)
+  : _ <~> IsSubring S
+  := ltac:(issig).
+
+Global Instance ishprop_issubring `{Funext} {R : Ring} (S : R -> Type)
+  : IsHProp (IsSubring S).
+Proof.
+  exact (istrunc_equiv_istrunc _ (issig_IsSubring S)).
+Defined.
+
+(** Subring criterion. *)
+Definition Build_IsSubring' {R : Ring} (S : R -> Type)
+  (H : forall x, IsHProp (S x))
+  (H1 : forall x y, S x -> S y -> S (x - y))
+  (H2 : forall x y, S x -> S y -> S (x * y))
+  (H3 : S 1)
+  : IsSubring S.
+Proof.
+  snrapply Build_IsSubring.
+  - snrapply Build_IsSubgroup'.
+    + exact _.
+    + pose (p := H1 1 1 H3 H3).
+      rewrite rng_plus_negate_r in p.
+      exact p.
+    + exact H1.
+  - exact H2.
+  - exact H3.
+Defined.
+
+Record Subring (R : Ring) := {
+  #[reversible=no]
+  subring_pred :> R -> Type;
+  subring_issubring :: IsSubring subring_pred;
+}.
+
+Definition Build_Subring'' {R : Ring} (S : Subgroup R)
+  (H1 : forall x y, S x -> S y -> S (x * y))
+  (H2 : S 1)
+  : Subring R.
+Proof.
+  snrapply (Build_Subring _ S).
+  snrapply Build_IsSubring.
+  - exact _.
+  - exact H1.
+  - exact H2.
+Defined.
+
+Definition Build_Subring' {R : Ring} (S : R -> Type)
+  (H : forall x, IsHProp (S x))
+  (H1 : forall x y, S x -> S y -> S (x - y))
+  (H2 : forall x y, S x -> S y -> S (x * y))
+  (H3 : S 1)
+  : Subring R
+  := Build_Subring R S (Build_IsSubring' S H H1 H2 H3).
+
+(** The underlying subgroup of a subring. *)
+Coercion subgroup_subring {R} : Subring R -> Subgroup R
+  := fun S => Build_Subgroup R S _.
+
+(** The ring given by a subring. *)
+Coercion ring_subring {R : Ring} (S : Subring R) : Ring.
+Proof.
+  snrapply (Build_Ring (subgroup_subring S)).
+  5: repeat split.
+  { intros [r ?] [s ?].
+    exists (r * s).
+    by apply issubring_mult. }
+  { exists 1.
+    apply issubring_one. }
+  3: exact _.
+  all: hnf; intros; srapply path_sigma_hprop.
+  - snrapply rng_dist_l.
+  - snrapply rng_dist_r.
+  - snrapply rng_mult_assoc.
+  - snrapply rng_mult_one_l.
+  - snrapply rng_mult_one_r.
+Defined.
+
+(** ** Product ring *)
+
+Definition ring_product : Ring -> Ring -> Ring.
+Proof.
+  intros R S.
+  snrapply Build_Ring.
+  1: exact (ab_biprod R S).
+  1: exact (fun '(r1 , s1) '(r2 , s2) => (r1 * r2 , s1 * s2)).
+  1: exact (ring_one , ring_one).
+  { intros [r1 s1] [r2 s2] [r3 s3].
+    apply path_prod; cbn; apply rng_dist_l. }
+  { intros [r1 s1] [r2 s2] [r3 s3].
+    apply path_prod; cbn; apply rng_dist_r. }
+  repeat split.
+  1: exact _.
+  { intros [r1 s1] [r2 s2] [r3 s3].
+    apply path_prod; cbn; apply rng_mult_assoc. }
+  1: intros [r1 s1]; apply path_prod; cbn; apply rng_mult_one_l.
+  1: intros [r1 s1]; apply path_prod; cbn; apply rng_mult_one_r.
+Defined.
+
+Infix "×" := ring_product : ring_scope.
+
+Definition ring_product_fst {R S : Ring} : R × S $-> R.
+Proof.
+  snrapply Build_RingHomomorphism.
+  1: exact fst.
+  repeat split.
+Defined.
+
+Definition ring_product_snd {R S : Ring} : R × S $-> S.
+Proof.
+  snrapply Build_RingHomomorphism.
+  1: exact snd.
+  repeat split.
+Defined.
+
+Definition ring_product_corec (R S T : Ring)
+  : (R $-> S) -> (R $-> T) -> (R $-> S × T).
+Proof.
+  intros f g.
+  srapply Build_RingHomomorphism'.
+  1: apply (ab_biprod_corec f g).
+  repeat split.
+  1: cbn; intros x y; apply path_prod; apply rng_homo_mult.
+  cbn; apply path_prod; apply rng_homo_one.
+Defined.
+
+Definition equiv_ring_product_corec `{Funext} (R S T : Ring)
+  : (R $-> S) * (R $-> T) <~> (R $-> S × T).
+Proof.
+  snrapply equiv_adjointify.
+  1: exact (uncurry (ring_product_corec _ _ _)).
+  { intros f.
+    exact (ring_product_fst $o f, ring_product_snd $o f). }
+  { hnf; intros f.
+    by apply path_hom. }
+  intros [f g].
+  apply path_prod.
+  1,2: by apply path_hom.
+Defined.
+
+Global Instance hasbinaryproducts_ring : HasBinaryProducts Ring.
+Proof.
+  intros R S.
+  snrapply Build_BinaryProduct.
+  - exact (R × S).
+  - exact ring_product_fst.
+  - exact ring_product_snd.
+  - exact (fun T => ring_product_corec T R S).
+  - cbn; reflexivity.
+  - cbn; reflexivity.
+  - intros T f g p q x.
+    exact (path_prod' (p x) (q x)).
+Defined.
+
+(** ** Image ring *)
+
+(** The image of a ring homomorphism *)
+Definition rng_image {R S : Ring} (f : R $-> S) : Subring S.
+Proof.
+  snrapply (Build_Subring'' (grp_image f)).
+  - simpl.
+    intros x y p q.
+    strip_truncations; apply tr.
+    destruct p as [a p'], q as [b q'].
+    exists (a * b).
+    refine (rng_homo_mult _ _ _ @ _).
+    f_ap.
+  - apply tr.
+    exists 1.
+    exact (rng_homo_one f).
+Defined.
+
+Lemma rng_homo_image_incl {R S} (f : RingHomomorphism R S)
+  : (rng_image f : Ring) $-> S.
+Proof.
+  snrapply Build_RingHomomorphism.
+  1: exact pr1.
+  repeat split.
+Defined.
+
+(** Image of a surjective ring homomorphism *)
+Lemma rng_image_issurj {R S} (f : RingHomomorphism R S) {issurj : IsSurjection f}
+  : (rng_image f : Ring) ≅ S.
+Proof.
+  snrapply Build_RingIsomorphism.
+  1: exact (rng_homo_image_incl f).
+  exact _.
+Defined. 
+
+(** ** Opposite Ring *)
+
+(** Given a ring [R] we can reverse the order of the multiplication to get another ring [R^op]. *)
+Definition rng_op : Ring -> Ring.
+Proof.
+  (** Let's carefully pull apart the ring structure and put it back together. Unfortunately, our definition of ring has some redundant data such as multiple hset assumptions, due to the mixing of algebraic strucutres. This isn't a problem in practice, but it does mean using typeclass inference here will pick up the wrong instance, therefore we carefully put it back together. See test/Algebra/Rings/Ring.v for a test checking this operation is definitionally involutive. *)
+  intros [R mult one
+    [is_abgroup [[monoid_ishset mult_assoc] li ri] ld rd]
+    mult_assoc_opp].
+  snrapply Build_Ring'.
+  4: split.
+  5: split.
+  5: split.
+  - exact R.
+  - exact (fun x y => mult y x).
+  - exact one.
+  - exact is_abgroup.
+  - exact monoid_ishset.
+  - exact mult_assoc_opp.
+  - exact ri.
+  - exact li.
+  - exact (fun x y z => rd y z x).
+  - exact (fun x y z => ld z x y).
+  - exact mult_assoc.
+Defined.
+
+(** The opposite ring is a functor. *)
+Global Instance is0functor_rng_op : Is0Functor rng_op.
+Proof.
+  snrapply Build_Is0Functor.
+  intros R S f.
+  snrapply Build_RingHomomorphism'.
+  - exact f.
+  - split.
+    + exact (fun x y => rng_homo_mult f y x).
+    + exact (rng_homo_one f).
+Defined.
+
+Global Instance is1functor_rng_op : Is1Functor rng_op.
+Proof.
+  snrapply Build_Is1Functor.
+  - intros R S f g p.
+    exact p.
+  - intros R; cbn; reflexivity.
+  - intros R S T f g; cbn; reflexivity.
+Defined.
+
+(** ** Powers *)
+
+(** Powers of ring elements *)
+Definition rng_power {R : Ring} (x : R) (n : nat) : R := nat_iter n (x *.) ring_one.
+
+(** Power laws *)
+Lemma rng_power_mult_law {R : Ring} (x : R) (n m : nat)
+  : (rng_power x n) * (rng_power x m) = rng_power x (n + m).
+Proof.
+  induction n as [|n IHn].
+  1: apply rng_mult_one_l.
+  refine ((rng_mult_assoc _ _ _)^ @ _).
+  exact (ap (x *.) IHn).
+Defined.
+
+(** ** Finite Sums *)
+
+(** Ring multiplication distributes over finite sums on the left. *)
+Definition rng_sum_dist_l {R : Ring} (n : nat) (f : forall k, (k < n)%nat -> R) (r : R)
+  : r * ab_sum n f = ab_sum n (fun k Hk => r * f k Hk).
+Proof.
+  induction n as [|n IHn].
+  1: apply rng_mult_zero_r.
+  lhs nrapply rng_dist_l; simpl; f_ap.
+Defined.
+
+(** Ring multiplication distributes over finite sums on the right. *)
+Definition rng_sum_dist_r {R : Ring} (n : nat) (f : forall k, (k < n)%nat -> R) (r : R)
+  : ab_sum n f * r = ab_sum n (fun k Hk => f k Hk * r).
+Proof.
+  induction n as [|n IHn].
+  1: apply rng_mult_zero_l.
+  lhs nrapply rng_dist_r; simpl; f_ap.
+Defined.
+
+(** ** Invertible elements *)
+
+(** An element [x] of a ring [R] is left invertible if there exists an element [y] such that [y * x = 1]. *)
+Class IsLeftInvertible (R : Ring) (x : R) := {
+  left_inverse_elem : R;
+  left_inverse_eq : left_inverse_elem * x = 1;
+}.
+
+Arguments left_inverse_elem {R} x {_}.
+Arguments left_inverse_eq {R} x {_}.
+
+Definition issig_IsLeftInvertible {R : Ring} (x : R)
+  : _ <~> IsLeftInvertible R x
+  := ltac:(issig).
+
+(** An element [x] of a ring [R] is right invertible if there exists an element [y] such that [x * y = 1]. We state this as a left invertible element of the opposite ring. *)
+Class IsRightInvertible (R : Ring) (x : R)
+  := isleftinvertible_rng_op :: IsLeftInvertible (rng_op R) x.
+
+Definition right_inverse_elem {R} x `{!IsRightInvertible R x} : R
+  := left_inverse_elem (R:=rng_op R) x.
+
+Definition right_inverse_eq {R} x `{!IsRightInvertible R x}
+  : x * right_inverse_elem x = 1
+  := left_inverse_eq (R:=rng_op R) x.
+
+(** An element [x] of a ring [R] is invertible if it is both left and right invertible. *)
+Class IsInvertible (R : Ring) (x : R) := Build_IsInvertible' {
+  isleftinvertible_isinvertible :: IsLeftInvertible R x;
+  isrightinvertible_isinvertible :: IsRightInvertible R x;
+}.
+
+(** We can show an element is invertible by providing an inverse element which is a left and right inverse similtaneously. We will later show that the two inverses of an invertible element must be equal anyway. *)
+Definition Build_IsInvertible {R : Ring} (x : R)
+  (inv : R) (inv_l : inv * x = 1) (inv_r : x * inv = 1)
+  : IsInvertible R x.
+Proof.
+  split.
+  - by exists inv.
+  - unfold IsRightInvertible.
+    by exists (inv : rng_op R).
+Defined.
+
+(** The invertible elements in [R] and [rng_op R] agree, by swapping the proofs of left and right invertibility. *)
+Definition isinvertible_rng_op (R : Ring) (x : R) `{!IsInvertible R x}
+  : IsInvertible (rng_op R) x.
+Proof.
+  split.
+  - exact (isrightinvertible_isinvertible).
+  - exact (isleftinvertible_isinvertible).
+Defined.
+
+(** *** Uniqueness of inverses *)
+
+(** This general lemma will be used for uniqueness results. *)
+Definition path_left_right_inverse {R : Ring} (x x' x'' : R)
+  (p : x' * x = 1) (q : x * x'' = 1)
+  : x' = x''.
+Proof.
+  rhs_V nrapply rng_mult_one_l.
+  rewrite <- p. 
+  rewrite <- simple_associativity.
+  rewrite q.
+  symmetry.
+  apply rng_mult_one_r.
+Defined.
+
+(** The left and right inverse of an invertible element are necessarily equal. *)
+Definition path_left_inverse_elem_right_inverse_elem
+  {R : Ring} x `{!IsInvertible R x}
+  : left_inverse_elem x = right_inverse_elem x.
+Proof.
+  nrapply (path_left_right_inverse x).
+  - apply left_inverse_eq.
+  - apply right_inverse_eq.
+Defined.
+
+(** It is therefore well-defined to talk about the inverse of an invertible element. *)
+Definition inverse_elem {R : Ring} (x : R) `{IsInvertible R x} : R
+  := left_inverse_elem x.
+
+(** Left cancellation for an invertible element. *)
+Definition rng_inv_l {R : Ring} (x : R) `{IsInvertible R x}
+  : inverse_elem x * x = 1.
+Proof.
+  apply left_inverse_eq.
+Defined.
+
+(** Right cancellation for an invertible element. *)
+Definition rng_inv_r {R : Ring} (x : R) `{IsInvertible R x}
+  : x * inverse_elem x = 1.
+Proof.
+  rhs_V nrapply (right_inverse_eq x).
+  f_ap.
+  apply path_left_inverse_elem_right_inverse_elem.
+Defined.
+
+(** Equal elements have equal inverses.  Note that we don't require that the proofs of invertibility are equal (over [p]).  It follows that the inverse of an invertible element [x] depends only on [x]. *)
+Definition isinvertible_unique {R : Ring} (x y : R) `{IsInvertible R x} `{IsInvertible R y} (p : x = y)
+  : inverse_elem x = inverse_elem y.
+Proof.
+  destruct p.
+  snrapply (path_left_right_inverse x).
+  - apply rng_inv_l.
+  - apply rng_inv_r.
+Defined.
+
+(** We can show that being invertible is equivalent to having an inverse element that is simultaneously a left and right inverse. *)
+Definition equiv_isinvertible_left_right_inverse {R : Ring} (x : R)
+  : {inv : R & prod (inv * x = 1) (x * inv = 1)} <~> IsInvertible R x.
+Proof.
+  equiv_via { i : IsInvertible R x & right_inverse_elem x = left_inverse_elem x }.
+  1: make_equiv_contr_basedpaths.
+  apply equiv_sigma_contr; intro i.
+  rapply contr_inhabited_hprop.
+  symmetry; apply path_left_inverse_elem_right_inverse_elem.
+Defined.
+
+(** Being invertible is a proposition. *)
+Global Instance ishprop_isinvertible {R x} : IsHProp (IsInvertible R x).
+Proof.
+  nrapply (istrunc_equiv_istrunc _ (equiv_isinvertible_left_right_inverse x)).
+  snrapply hprop_allpath; intros [y [p1 p2]] [z [q1 q2]].
+  rapply path_sigma_hprop; cbn.
+  exact (path_left_right_inverse x y z p1 q2).
+Defined.
+
+(** *** Closure of invertible elements under multiplication *)
+
+(** Left invertible elements are closed under multiplication. *)
+Global Instance isleftinvertible_mult {R : Ring} (x y : R)
+  : IsLeftInvertible R x -> IsLeftInvertible R y -> IsLeftInvertible R (x * y).
+Proof.
+  intros [x' p] [y' q].
+  exists (y' * x').
+  rhs_V nrapply q.
+  lhs nrapply rng_mult_assoc.
+  f_ap.
+  rhs_V nrapply rng_mult_one_r.
+  lhs_V nrapply rng_mult_assoc.
+  f_ap.
+Defined.
+
+(** Right invertible elements are closed under multiplication. *)
+Global Instance isrightinvertible_mult {R : Ring} (x y : R)
+  : IsRightInvertible R x -> IsRightInvertible R y -> IsRightInvertible R (x * y).
+Proof.
+  change (x * y) with (ring_mult (R:=rng_op R) y x).
+  unfold IsRightInvertible.
+  exact _.
+Defined.
+
+(** Invertible elements are closed under multiplication. *)
+Global Instance isinvertible_mult {R : Ring} (x y : R)
+  : IsInvertible R x -> IsInvertible R y -> IsInvertible R (x * y)
+  := {}.
+
+(** Left invertible elements are closed under negation. *)
+Global Instance isleftinvertible_neg {R : Ring} (x : R)
+  : IsLeftInvertible R x -> IsLeftInvertible R (-x).
+Proof.
+  intros H.
+  exists (- left_inverse_elem x).
+  lhs nrapply rng_mult_negate_negate.
+  apply left_inverse_eq.
+Defined.
+
+(** Right invertible elements are closed under negation. *)
+Global Instance isrightinvertible_neg {R : Ring} (x : R)
+  : IsRightInvertible R x -> IsRightInvertible R (-x).
+Proof.
+  intros H.
+  rapply isleftinvertible_neg.
+Defined.
+
+(** Invertible elements are closed under negation. *)
+Global Instance isinvertible_neg {R : Ring} (x : R)
+  : IsInvertible R x -> IsInvertible R (-x)
+  := {}.
+
+(** Inverses of left invertible elements are themselves right invertible. *)
+Global Instance isrightinvertible_left_inverse_elem {R : Ring} (x : R)
+  `{IsLeftInvertible R x}
+  : IsRightInvertible R (left_inverse_elem x).
+Proof.
+  exists (x : rng_op R).
+  exact (left_inverse_eq x).
+Defined.
+
+(** Inverses of right invertible elements are themselves left invertible. *)
+Global Instance isleftinvertible_right_inverse_elem {R : Ring} (x : R)
+  `{IsRightInvertible R x}
+  : IsLeftInvertible R (right_inverse_elem x).
+Proof.
+  exists x.
+  exact (right_inverse_eq x).
+Defined.
+
+(** Inverses of invertible elements are themselves invertible.  We take both inverses of [inverse_elem x] to be [x]. *)
+Global Instance isinvertible_inverse_elem {R : Ring} (x : R)
+  `{IsInvertible R x}
+  : IsInvertible R (inverse_elem x).
+Proof.
+  split.
+  - exists x; apply rng_inv_r.
+  - apply isrightinvertible_left_inverse_elem.
+Defined.
+
+(** Since [inverse_elem (inverse_elem x) = x], we get the following equivalence. *)
+Definition equiv_path_inverse_elem {R : Ring} {x y : R}
+  `{IsInvertible R x, IsInvertible R y}
+  : x = y <~> inverse_elem x = inverse_elem y.
+Proof.
+  srapply equiv_iff_hprop.
+  - exact (isinvertible_unique x y).
+  - exact (isinvertible_unique (inverse_elem x) (inverse_elem y)).
+Defined.
+
+(** [1] is always invertible, and by the above [-1]. *)
+Global Instance isinvertible_one {R} : IsInvertible R 1.
+Proof.
+  snrapply Build_IsInvertible.
+  - exact one.
+  - apply rng_mult_one_l.
+  - apply rng_mult_one_l.
+Defined.
+
+(** Ring homomorphisms preserve invertible elements. *)
+Global Instance isinvertible_rng_homo {R S} (f : R $-> S)
+  : forall x, IsInvertible R x -> IsInvertible S (f x).
+Proof.
+  intros x H.
+  snrapply Build_IsInvertible.
+  1: exact (f (inverse_elem x)).
+  1,2: lhs_V nrapply rng_homo_mult.
+  1,2: rhs_V nrapply (rng_homo_one f).
+  1,2: nrapply (ap f).
+  - exact (rng_inv_l x).
+  - exact (rng_inv_r x).
+Defined.
+
+(** *** Group of units *)
+
+(** Invertible elements are typically called "units" in ring theory and the collection of units forms a group under the ring multiplication. *)
+Definition rng_unit_group (R : Ring) : Group.
+Proof.
+  (** TODO: Use a generalised version of [Build_Subgroup] that works for subgroups of monoids. *)
+  snrapply Build_Group.
+  - exact {x : R & IsInvertible R x}.
+  - intros [x p] [y q].
+    exists (x * y).
+    exact _.
+  - exists 1.
+    exact _.
+  - intros [x p].
+    exists (inverse_elem x).
+    exact _.
+  - repeat split.
+    1: exact _.
+    1-5: hnf; intros; apply path_sigma_hprop.
+    + rapply simple_associativity.
+    + rapply left_identity.
+    + rapply right_identity.
+    + apply rng_inv_l.
+    + apply rng_inv_r.
+Defined.
+
+(** *** Multiplication by an invertible element is an equivalence *)
+
+Global Instance isequiv_rng_inv_mult_l {R : Ring} {x : R}
+  `{IsInvertible R x}
+  : IsEquiv (x *.).
+Proof.
+  snrapply isequiv_adjointify.
+  1: exact (inverse_elem x *.).
+  1,2: intros y.
+  1,2: lhs nrapply rng_mult_assoc.
+  1,2: rhs_V nrapply rng_mult_one_l.
+  1,2: snrapply (ap (.* y)).
+  - nrapply rng_inv_r.
+  - nrapply rng_inv_l.
+Defined.
+
+(** This can be proved by combining [isequiv_rng_inv_mult_l (R:=rng_op R)] with [isinvertible_rng_op], but then the inverse map is given by multiplying by [right_inverse_elem x] not [inverse_elem x], which complicates calculations. *)
+Global Instance isequiv_rng_inv_mult_r {R : Ring} {x : R}
+  `{IsInvertible R x}
+  : IsEquiv (.* x).
+Proof.
+  snrapply isequiv_adjointify.
+  1: exact (.* inverse_elem x).
+  1,2: intros y.
+  1,2: lhs_V nrapply rng_mult_assoc.
+  1,2: rhs_V nrapply rng_mult_one_r.
+  1,2: snrapply (ap (y *.)).
+  - nrapply rng_inv_l.
+  - nrapply rng_inv_r.
+Defined.
+
+(** *** Invertible element movement lemmas *)
+
+(** These cannot be proven using the corresponding group laws in the group of units since not all elements involved are invertible. *)
+
+Definition rng_inv_moveL_Vr {R : Ring} {x y z : R} `{IsInvertible R y}
+  : y * x = z <~> x = inverse_elem y * z
+  := equiv_moveL_equiv_V (f := (y *.)) z x.
+
+Definition rng_inv_moveL_rV {R : Ring} {x y z : R} `{IsInvertible R y}
+  : x * y = z <~> x = z * inverse_elem y
+  := equiv_moveL_equiv_V (f := (.* y)) z x.
+
+Definition rng_inv_moveR_Vr {R : Ring} {x y z : R} `{IsInvertible R y}
+  : x = y * z <~> inverse_elem y * x = z
+  := equiv_moveR_equiv_V (f := (y *.)) x z.
+
+Definition rng_inv_moveR_rV {R : Ring} {x y z : R} `{IsInvertible R y}
+  : x = z * y <~> x * inverse_elem y = z
+  := equiv_moveR_equiv_V (f := (.* y)) x z.
+
+(** TODO: The group of units construction is a functor from [Ring -> Group] and is right adjoint to the group ring construction. *)
diff --git a/theories/Algebra/Rings/Vector.v b/theories/Algebra/Rings/Vector.v
new file mode 100644
index 00000000000..f391540eb39
--- /dev/null
+++ b/theories/Algebra/Rings/Vector.v
@@ -0,0 +1,219 @@
+Require Import Basics.Overture Basics.Trunc Basics.Tactics Basics.PathGroupoids.
+Require Import Types.Sigma.
+Require Import Algebra.AbGroups.AbelianGroup Algebra.Rings.Ring Algebra.Rings.Module.
+Require Import Spaces.Nat.Core.
+Require Import Spaces.List.Core Spaces.List.Theory Spaces.List.Paths.
+Require Import abstract_algebra.
+
+Local Open Scope mc_scope.
+
+Local Set Universe Minimization ToSet.
+Local Set Polymorphic Inductive Cumulativity.
+
+(** * Vectors *)
+
+(** A vector is simply a list with a specified length. This data structure has many uses, but here we will focus on lists of left module elements. *)
+
+(** ** Definition *)
+
+Definition Vector@{i|} (A : Type@{i}) (n : nat) : Type@{i}
+  := { l : list A & length l = n }.
+
+(** *** Constructors *)
+
+Definition Build_Vector (A : Type) (n : nat)
+  (f : forall (i : nat), (i < n)%nat -> A)
+  : Vector A n. 
+Proof.
+  exists (list_map (fun '(i; Hi) => f i Hi) (seq' n)).
+  lhs nrapply length_list_map.
+  apply length_seq'.
+Defined.
+
+(** *** Projections *)
+
+Definition entry {A : Type} {n : nat} (v : Vector A n) i {Hi : (i < n)%nat} : A
+  := nth' (pr1 v) i ((pr2 v)^ # Hi).
+
+(** *** Basic properties *) 
+
+Definition entry_Build_Vector {A : Type} {n}
+  (f : forall (i : nat), (i < n)%nat -> A) i {Hi : (i < n)%nat}
+  : entry (Build_Vector A n f) i = f i Hi.
+Proof.
+  snrefine (nth'_list_map _ _ _ (_^ # Hi) _ @ _).
+  1: nrapply length_seq'.
+  snrapply ap011D.
+  1: nrapply nth'_seq'.
+  rapply path_ishprop. 
+Defined.
+
+Global Instance istrunc_vector@{i} (A : Type@{i}) (n : nat) k `{IsTrunc k.+2 A}
+  : IsTrunc k.+2 (Vector A n).
+Proof.
+  rapply istrunc_sigma@{i i i}.
+Defined.
+
+Definition path_vector@{i} (A : Type@{i}) {n : nat} (v1 v2 : Vector@{i} A n)
+  (H : forall i (H : (i < n)%nat), entry v1 i = entry v2 i)
+  : v1 = v2.
+Proof.
+  rapply path_sigma_hprop@{i i i}.
+  snrapply path_list_nth'.
+  1: exact (pr2 v1 @ (pr2 v2)^).
+  intros i Hi.
+  snrefine (_ @ H i (pr2 v1 # Hi) @ _).
+  1, 2: apply nth'_nth'.
+Defined.
+
+Definition path_entry_vector {A : Type} {n : nat} (v : Vector A n)
+  (i j : nat) (Hi : (i < n)%nat) (Hj : (j < n)%nat) (p : i = j)
+  : entry v i = entry v j.
+Proof.
+  destruct p.
+  apply nth'_nth'.
+Defined.
+
+(** ** Operations *)
+
+Definition vector_map {A B : Type} {n} (f : A -> B)
+  : Vector A n -> Vector B n
+  := fun v => Build_Vector B n (fun i _ => f (entry v i)).
+
+Definition vector_map2 {A B C : Type} {n} (f : A -> B -> C)
+  : Vector A n -> Vector B n -> Vector C n
+  := fun v1 v2 => Build_Vector C n (fun i _ => f (entry v1 i) (entry v2 i)).
+
+(** ** Abelian group structure *)
+
+Section VectorAddition.
+
+  Context (A : AbGroup) (n : nat).
+
+  Definition vector_plus : Plus (Vector A n) := vector_map2 (+).
+
+  Definition vector_zero : Zero (Vector A n)
+    := Build_Vector A n (fun _ _ => 0).
+
+  Definition vector_neg : Negate (Vector A n) := vector_map (-).
+
+  Definition associative_vector_plus : Associative vector_plus.
+  Proof.
+    intros v1 v2 v3; apply path_vector; intros i Hi.
+    rewrite 4 entry_Build_Vector.
+    apply associativity.
+  Defined.
+  
+  Definition commutative_vector_plus : Commutative vector_plus.
+  Proof.
+    intros v1 v2; apply path_vector; intros i Hi.
+    rewrite 2 entry_Build_Vector.
+    apply commutativity.
+  Defined.
+
+  Definition left_identity_vector_plus : LeftIdentity vector_plus vector_zero.
+  Proof.
+    intros v; apply path_vector; intros i Hi.
+    rewrite 2 entry_Build_Vector.
+    apply left_identity.
+  Defined.
+
+  Definition right_identity_vector_plus : RightIdentity vector_plus vector_zero.
+  Proof.
+    intros v; apply path_vector; intros i Hi.
+    rewrite 2 entry_Build_Vector.
+    apply right_identity.
+  Defined.
+
+  Definition left_inverse_vector_plus
+    : LeftInverse vector_plus vector_neg vector_zero.
+  Proof.
+    intros v; apply path_vector; intros i Hi.
+    rewrite 3 entry_Build_Vector.
+    apply left_inverse.
+  Defined.
+
+  Definition right_inverse_vector_plus
+    : RightInverse vector_plus vector_neg vector_zero.
+  Proof.
+    intros v; apply path_vector; intros i Hi.
+    rewrite 3 entry_Build_Vector.
+    apply right_inverse.
+  Defined.
+
+  Definition abgroup_vector : AbGroup.
+  Proof.
+    snrapply Build_AbGroup.
+    1: snrapply Build_Group.
+    5: repeat split.
+    - exact (Vector A n).
+    - exact vector_plus.
+    - exact vector_zero.
+    - exact vector_neg.
+    - exact _.
+    - exact associative_vector_plus.
+    - exact left_identity_vector_plus.
+    - exact right_identity_vector_plus.
+    - exact left_inverse_vector_plus.
+    - exact right_inverse_vector_plus.
+    - exact commutative_vector_plus.
+  Defined.
+
+End VectorAddition.
+
+Arguments vector_plus {A n} v1 v2.
+
+(** ** Module structure *)
+
+Section VectorScale.
+  (** A vector of elements of an R-module is itself an R-module. A special case is when the R-module is the ring R itself. *)
+  Context (M : AbGroup) (n : nat) {R : Ring} `{IsLeftModule R M}.
+
+  Definition vector_lact (r : R) : Vector M n -> Vector M n
+    := vector_map (lact r).
+  
+  Definition left_heterodistribute_vector_lact_plus
+    : LeftHeteroDistribute vector_lact vector_plus vector_plus.
+  Proof.
+    intros r v1 v2; apply path_vector; intros i Hi.
+    rewrite 5 entry_Build_Vector.
+    apply distribute_l.
+  Defined.
+
+  Definition right_heterodistribute_vector_lact_plus
+    : RightHeteroDistribute vector_lact (+) vector_plus.
+  Proof.
+    intros r1 r2 v; apply path_vector; intros i Hi.
+    rewrite 4 entry_Build_Vector.
+    apply distribute_r.
+  Defined.
+
+  Definition heteroassociative_vector_lact_plus
+    : HeteroAssociative vector_lact vector_lact vector_lact (.*.).
+  Proof.
+    intros r s v; apply path_vector; intros i Hi.
+    rewrite 3 entry_Build_Vector.
+    apply associativity.
+  Defined.
+
+  Definition left_identity_vector_lact : LeftIdentity vector_lact 1.
+  Proof.
+    intros v; apply path_vector; intros i Hi.
+    rewrite entry_Build_Vector.
+    apply left_identity.
+  Defined.
+
+  Definition isleftmodule_isleftmodule_vector
+    : IsLeftModule R (abgroup_vector M n).
+  Proof.
+    snrapply Build_IsLeftModule.
+    - exact vector_lact.
+    - exact left_heterodistribute_vector_lact_plus.
+    - exact right_heterodistribute_vector_lact_plus.
+    - exact heteroassociative_vector_lact_plus.
+    - exact left_identity_vector_lact.
+  Defined.
+
+End VectorScale.
+
+Arguments vector_lact {M n R _} r v.
diff --git a/theories/Algebra/Rings/Z.v b/theories/Algebra/Rings/Z.v
index b2a63ec2130..0d9cf3b124b 100644
--- a/theories/Algebra/Rings/Z.v
+++ b/theories/Algebra/Rings/Z.v
@@ -1,219 +1,65 @@
-Require Import Classes.interfaces.abstract_algebra.
+Require Import Classes.interfaces.canonical_names.
 Require Import Algebra.AbGroups.
 Require Import Algebra.Rings.CRing.
 Require Import Spaces.Int Spaces.Pos.
 Require Import WildCat.Core.
 
-(** In this file we define the ring Z of integers. The underlying abelian group is already defined in Algebra.AbGroups.Z. Many of the ring axioms are proven and made opaque. Typically, everything inside IsRing can be opaque since we will only ever rewrite along them and they are hprops. This also means we don't have to be too careful with how our proofs are structured. This allows us to freely use tactics such as rewrite. It would perhaps be possible to shorten many of the proofs here, but it would probably be unneeded due to the opacicty. *)
+(** * In this file we define the ring [cring_Z] of integers with underlying abelian group [abgroup_Z] defined in Algebra.AbGroups.Z. We also define multiplication by an integer in a general ring, and show that [cring_Z] is initial. *)
 
 (** The ring of integers *)
 Definition cring_Z : CRing.
 Proof.
-  snrapply (Build_CRing abgroup_Z int_add int_mul 0%int 1%int); only 2: repeat split; try exact _.
-  + exact int_mul_assoc.
-  + exact int_mul_1_l.
-  + exact int_mul_1_r.
-  + exact int_mul_comm.
-  + exact int_mul_add_distr_l.
+  snrapply Build_CRing'.
+  - exact abgroup_Z.
+  - exact 1%int.
+  - exact int_mul.
+  - exact int_mul_comm.
+  - exact int_mul_assoc.
+  - exact int_dist_l.
+  - exact int_mul_1_l.
 Defined.
 
 Local Open Scope mc_scope.
 
-(** Multiplication of a ring element by an integer. *)
-(** We call this a "catamorphism" which is the name of the map from an initial object. It seems to be a more common terminology in computer science. *)
-Definition cring_catamorphism_fun (R : CRing) (z : cring_Z) : R
-  := match z with
-     | neg z => pos_peano_rec R (-1) (fun n nr => -1 + nr) z
-     | 0%int => 0
-     | pos z => pos_peano_rec R 1 (fun n nr => 1 + nr) z
-     end.
+(** Given a ring element [r], we get a map [Int -> R] sending an integer to that multiple of [r]. *)
+Definition rng_int_mult (R : Ring) := grp_pow_homo : R -> Int -> R.
 
-(** TODO: remove these (they will be cleaned up in the future)*)
-(** Left multiplication is an equivalence *)
-Local Instance isequiv_group_left_op {G} `{IsGroup G}
-  : forall (x : G), IsEquiv (fun t => sg_op x t).
+(** Multiplying a ring element [r] by an integer [n] is equivalent to first multiplying the unit [1] of the ring by [n], and then multiplying the result by [r].  This is distributivity of right multiplication by [r] over the sum. *)
+Definition rng_int_mult_dist_r {R : Ring} (r : R) (n : cring_Z)
+  : rng_int_mult R r n = (rng_int_mult R 1 n) * r.
 Proof.
-  intro x.
-  srapply isequiv_adjointify.
-  1: exact (sg_op (-x)).
-  all: intro y.
-  all: refine (associativity _ _ _ @ _ @ left_identity y).
-  all: refine (ap (fun x => x * y) _).
-  1: apply right_inverse.
-  apply left_inverse.
+  cbn.
+  rhs nrapply (grp_pow_natural (grp_homo_rng_right_mult r)); cbn.
+  by rewrite rng_mult_one_l.
 Defined.
 
-(** Right multiplication is an equivalence *)
-Local Instance isequiv_group_right_op {G} `{IsGroup G}
-  : forall x:G, IsEquiv (fun y => sg_op y x).
+(** Similarly, there is a left-distributive law. *)
+Definition rng_int_mult_dist_l {R : Ring} (r : R) (n : cring_Z)
+  : rng_int_mult R r n = r * (rng_int_mult R 1 n).
 Proof.
-  intro x.
-  srapply isequiv_adjointify.
-  1: exact (fun y => sg_op y (- x)).
-  all: intro y.
-  all: refine ((associativity _ _ _)^ @ _ @ right_identity y).
-  all: refine (ap (y *.) _).
-  1: apply left_inverse.
-  apply right_inverse.
+  cbn.
+  rhs nrapply (grp_pow_natural (grp_homo_rng_left_mult r)); cbn.
+  by rewrite rng_mult_one_r.
 Defined.
 
-(** Preservation of + *)
-Global Instance issemigrouppreserving_cring_catamorphism_fun_plus (R : CRing)
-  : IsSemiGroupPreserving (Aop:=cring_plus) (Bop:=cring_plus)
-      (cring_catamorphism_fun R : cring_Z -> R).
+(** [rng_int_mult R 1] preserves multiplication.  This requires that the specified ring element is the unit. *)
+Global Instance issemigrouppreserving_mult_rng_int_mult (R : Ring)
+  : IsSemiGroupPreserving (A:=cring_Z) (Aop:=(.*.)) (Bop:=(.*.)) (rng_int_mult R 1).
 Proof.
-  (** Unfortunately, due to how we have defined things we need to seperate this out into 9 cases. *)
-  hnf. intros [x| |x] [y| |y].
-  (** Some of these cases are easy however *)
-  2,5,8: cbn; by rewrite right_identity.
-  3,4: symmetry; apply left_identity.
-  (** This leaves us with four cases to consider *)
-  (** x < 0 , y < 0 *)
-  { change (cring_catamorphism_fun R ((neg x) + (neg y))%int
-      = (cring_catamorphism_fun R (neg x)) + (cring_catamorphism_fun R (neg y))).
-    induction y as [|y IHy] using pos_peano_ind.
-    { simpl.
-      rewrite pos_add_1_r.
-      rewrite pos_peano_rec_beta_pos_succ.
-      apply commutativity. }
-    simpl.
-    rewrite pos_add_succ_r.
-    rewrite 2 pos_peano_rec_beta_pos_succ.
-    rewrite simple_associativity.
-    rewrite (commutativity _ (-1)).
-    rewrite <- simple_associativity.
-    f_ap. }
-  (** x < 0 , y > 0 *)
-  { cbn.
-    revert x.
-    induction y as [|y IHy] using pos_peano_ind; intro x.
-    { cbn.
-      induction x as [|x] using pos_peano_ind.
-      1: symmetry; cbn; apply left_inverse.
-      rewrite pos_peano_rec_beta_pos_succ.
-      rewrite int_pos_sub_succ_r.
-      cbn; rewrite <- simple_associativity.
-      apply rng_moveL_Mr.
-      cbn; rewrite involutive.
-      apply commutativity. }
-    induction x as [|x IHx] using pos_peano_ind.
-    { rewrite int_pos_sub_succ_l.
-      cbn; apply rng_moveL_Mr.
-      cbn; rewrite involutive.
-      by rewrite pos_peano_rec_beta_pos_succ. }
-    rewrite int_pos_sub_succ_succ.
-    rewrite IHy.
-    rewrite 2 pos_peano_rec_beta_pos_succ.
-    rewrite (commutativity (-1)).
-    rewrite simple_associativity.
-    rewrite <- (simple_associativity _ _ 1).
-    rewrite left_inverse.
-    f_ap.
-    symmetry.
-    apply right_identity. }
-  - cbn.
-    revert x.
-    induction y as [|y IHy] using pos_peano_ind; intro x.
-    { induction x as [|x] using pos_peano_ind.
-      1: symmetry; cbn; apply right_inverse.
-      rewrite pos_peano_rec_beta_pos_succ.
-      rewrite (commutativity 1).
-      rewrite <- simple_associativity.
-      rewrite int_pos_sub_succ_l.
-      cbn; by rewrite right_inverse, right_identity. }
-    induction x as [|x IHx] using pos_peano_ind.
-    { rewrite int_pos_sub_succ_r.
-      rewrite pos_peano_rec_beta_pos_succ.
-      rewrite simple_associativity.
-      cbn.
-      rewrite (right_inverse 1).
-      symmetry.
-      apply left_identity. }
-    rewrite int_pos_sub_succ_succ.
-    rewrite IHy.
-    rewrite 2 pos_peano_rec_beta_pos_succ.
-    rewrite (commutativity 1).
-    rewrite simple_associativity.
-    rewrite <- (simple_associativity _ _ (-1)).
-    rewrite (right_inverse 1).
-    f_ap; symmetry.
-    apply right_identity.
-  - cbn.
-    induction y as [|y IHy] using pos_peano_ind.
-    { cbn.
-      rewrite pos_add_1_r.
-      rewrite pos_peano_rec_beta_pos_succ.
-      apply commutativity. }
-    rewrite pos_add_succ_r.
-    rewrite 2 pos_peano_rec_beta_pos_succ.
-    rewrite simple_associativity.
-    rewrite IHy.
-    rewrite simple_associativity.
-    rewrite (commutativity 1).
-    reflexivity.
-Qed.
-
-Lemma cring_catamorphism_fun_negate {R} x
-  : cring_catamorphism_fun R (- x) = - cring_catamorphism_fun R x.
-Proof.
-  snrapply (groups.preserves_negate _).
-  1-6: typeclasses eauto.
-  snrapply Build_IsMonoidPreserving.
-  1: exact _.
-  split.
+  intros x y.
+  cbn; unfold sg_op.
+  lhs nrapply grp_pow_int_mul.
+  nrapply rng_int_mult_dist_l.
 Defined.
 
-Lemma cring_catamorphism_fun_pos_mult {R} x y
-  : cring_catamorphism_fun R (pos x * pos y)%int
-    = cring_catamorphism_fun R (pos x) * cring_catamorphism_fun R (pos y).
-Proof.
-  revert y.
-  induction x as [|x IHx] using pos_peano_ind; intro y.
-  { symmetry.
-    apply left_identity. }
-  change (cring_catamorphism_fun R (pos (pos_succ x * y)%pos)
-    = cring_catamorphism_fun R (pos (pos_succ x)) * cring_catamorphism_fun R (pos y)).
-  rewrite pos_mul_succ_l.
-  refine (issemigrouppreserving_cring_catamorphism_fun_plus
-    R (pos (x * y)%pos) (pos y) @ _).
-  rewrite IHx.
-  transitivity ((1 + cring_catamorphism_fun R (pos x)) * cring_catamorphism_fun R (pos y)).
-  2: simpl; by rewrite pos_peano_rec_beta_pos_succ.
-  rewrite rng_dist_r.
-  rewrite rng_mult_one_l.
-  apply commutativity.
-Qed.
-
-(** Preservation of * (multiplication) *)
-Global Instance issemigrouppreserving_cring_catamorphism_fun_mult (R : CRing)
-  : IsSemiGroupPreserving (Aop:=cring_mult) (Bop:=cring_mult)
-      (cring_catamorphism_fun R : cring_Z -> R).
+(** [rng_int_mult R 1] is a ring homomorphism *)
+Definition rng_homo_int (R : Ring) : (cring_Z : Ring) $-> R.
 Proof.
-  hnf. intros [x| |x] [y| |y].
-  2,5,8: symmetry; apply rng_mult_zero_r.
-  3,4: cbn; symmetry; rewrite (commutativity 0); apply rng_mult_zero_r.
-  { change (cring_catamorphism_fun R (pos (x * y)%pos)
-      = cring_catamorphism_fun R (- (pos x : cring_Z))
-        * cring_catamorphism_fun R (- (pos y : cring_Z))).
-    by rewrite 2 cring_catamorphism_fun_negate, cring_catamorphism_fun_pos_mult,
-      rng_mult_negate_negate. }
-  { change (cring_catamorphism_fun R (- (pos (x * y)%pos : cring_Z))
-      = cring_catamorphism_fun R (- (pos x : cring_Z))
-        * cring_catamorphism_fun R (pos y)).
-    by rewrite 2 cring_catamorphism_fun_negate, cring_catamorphism_fun_pos_mult, rng_mult_negate_l. }
-  { change (cring_catamorphism_fun R (- (pos (x * y)%pos : cring_Z))
-      = cring_catamorphism_fun R (pos x)
-        * cring_catamorphism_fun R (- (pos y : cring_Z))).
-    by rewrite 2 cring_catamorphism_fun_negate, cring_catamorphism_fun_pos_mult, rng_mult_negate_r. }
-  apply cring_catamorphism_fun_pos_mult.
-Qed.
-
-(** This is a ring homomorphism *)
-Definition rng_homo_int (R : CRing) : cring_Z $-> R.
-Proof.
-  snrapply Build_CRingHomomorphism.
-  1: exact (cring_catamorphism_fun R).
-  repeat split; exact _.
+  snrapply Build_RingHomomorphism.
+  1: exact (rng_int_mult R 1).
+  repeat split.
+  1,2: exact _.
+  apply rng_plus_zero_r.
 Defined.
 
 (** The integers are the initial commutative ring *)
@@ -223,28 +69,19 @@ Proof.
   intro R.
   exists (rng_homo_int R).
   intros g x.
-  destruct x as [n| |p].
-  + induction n using pos_peano_ind.
-    { cbn. symmetry; rapply rng_homo_minus_one. }
-    simpl.
-    rewrite pos_peano_rec_beta_pos_succ.
-    rewrite int_neg_pos_succ.
-    unfold int_pred.
-    rewrite int_add_comm.
-    rewrite rng_homo_plus.
-    rewrite rng_homo_minus_one.
-    apply ap.
-    exact IHn.
-  + by rewrite 2 rng_homo_zero.
-  + induction p using pos_peano_ind.
-    { cbn. symmetry; rapply rng_homo_one. }
-    simpl.
-    rewrite pos_peano_rec_beta_pos_succ.
-    rewrite int_pos_pos_succ.
-    unfold int_succ.
-    rewrite int_add_comm.
-    rewrite rng_homo_plus.
+  unfold rng_homo_int, rng_int_mult; cbn.
+  induction x as [|x|x].
+  - by rhs nrapply (grp_homo_unit g).
+  - rewrite grp_pow_succ.
+    change (x.+1%int) with (1 + x)%int.
+    rewrite (rng_homo_plus g 1 x).
     rewrite rng_homo_one.
-    apply ap.
-    exact IHp.
+    f_ap.
+  - rewrite grp_pow_pred.
+    rewrite IHx.
+    clear IHx.
+    rewrite <- (rng_homo_one g).
+    rewrite <- (rng_homo_negate g).
+    lhs_V nrapply (rng_homo_plus g).
+    f_ap.
 Defined.
diff --git a/theories/Algebra/Universal/Algebra.v b/theories/Algebra/Universal/Algebra.v
index 6e6f67ed721..ba410610c96 100644
--- a/theories/Algebra/Universal/Algebra.v
+++ b/theories/Algebra/Universal/Algebra.v
@@ -7,8 +7,7 @@ Local Unset Elimination Schemes.
 Require Export HoTT.Basics.
 
 Require Import
-  HoTT.Types
-  HoTT.HSet.
+  HoTT.Types.
 
 Declare Scope Algebra_scope.
 Delimit Scope Algebra_scope with Algebra.
@@ -117,7 +116,7 @@ Proof.
   exact q.
 Defined.
 
-Arguments path_algebra {_} {_} (A B)%Algebra_scope (p q)%path_scope.
+Arguments path_algebra {_} {_} (A B)%_Algebra_scope (p q)%_path_scope.
 
 Lemma path_ap_carriers_path_algebra `{Funext} {σ} (A B : Algebra σ)
   (p : carriers A = carriers B)
@@ -132,7 +131,7 @@ Proof.
   now destruct (center (ha = hb)).
 Defined.
 
-Arguments path_ap_carriers_path_algebra {_} {_} (A B)%Algebra_scope (p q)%path_scope.
+Arguments path_ap_carriers_path_algebra {_} {_} (A B)%_Algebra_scope (p q)%_path_scope.
 
 Lemma path_path_algebra_issig {σ : Signature} {A B : Algebra σ} (p q : A = B)
   (r : ap (issig_algebra σ)^-1 p = ap (issig_algebra σ)^-1 q)
@@ -142,7 +141,7 @@ Proof.
   by apply (@equiv_inv _ _ (ap e) (Equivalences.isequiv_ap _ _)).
 Defined.
 
-Arguments path_path_algebra_issig {_} {A B}%Algebra_scope (p q r)%path_scope.
+Arguments path_path_algebra_issig {_} {A B}%_Algebra_scope (p q r)%_path_scope.
 
 Lemma path_path_algebra `{Funext} {σ} {A B : Algebra σ}
   (p q : A = B) (r : ap carriers p = ap carriers q)
@@ -155,6 +154,6 @@ Proof.
   - apply path_ishprop.
 Defined.
 
-Arguments path_path_algebra {_} {σ} {A B}%Algebra_scope (p q r)%path_scope.
+Arguments path_path_algebra {_} {σ} {A B}%_Algebra_scope (p q r)%_path_scope.
 
 Global Notation "u .# A" := (operations A u) : Algebra_scope.
diff --git a/theories/Algebra/Universal/Homomorphism.v b/theories/Algebra/Universal/Homomorphism.v
index 4a05d4f462b..7e39a877131 100644
--- a/theories/Algebra/Universal/Homomorphism.v
+++ b/theories/Algebra/Universal/Homomorphism.v
@@ -98,7 +98,7 @@ Section homomorphism_id.
 
 End homomorphism_id.
 
-Arguments homomorphism_id {σ} A%Algebra_scope , {σ} {A}.
+Arguments homomorphism_id {σ} A%_Algebra_scope , {σ} {A}.
 
 (** Composition of homomorphisms. *)
 
@@ -190,6 +190,7 @@ Global Instance is1cat_strong_algebra `{Funext} (σ : Signature)
 Proof.
   rapply Build_Is1Cat_Strong.
   - intros. apply assoc_homomorphism_compose.
+  - intros. symmetry; apply assoc_homomorphism_compose.
   - intros. apply left_id_homomorphism_compose.
   - intros. apply right_id_homomorphism_compose.
 Defined.
diff --git a/theories/Algebra/Universal/Operation.v b/theories/Algebra/Universal/Operation.v
index e3c27f4ad2f..bcdc0c2d876 100644
--- a/theories/Algebra/Universal/Operation.v
+++ b/theories/Algebra/Universal/Operation.v
@@ -20,7 +20,7 @@ Monomorphic Definition head_dom' {σ} (A : Carriers σ) (n : nat)
   : forall (N : n > 0) (ss : FinSeq n (Sort σ)) (a : forall i, A (ss i)),
     A (fshead' n N ss)
   := match n with
-     | 0 => fun N ss _ => Empty_rec (not_lt_n_n _ N)
+     | 0 => fun N ss _ => Empty_rec (lt_irrefl _ N)
      | n'.+1 => fun N ss a => a fin_zero
      end.
 
@@ -33,7 +33,7 @@ Monomorphic Definition head_dom {σ} (A : Carriers σ) {n : nat}
     of an operation domain [a : forall i, A (ss i)]. *)
 
 Monomorphic Definition tail_dom' {σ} (A : Carriers σ) (n : nat)
-  : forall (ss : FinSeq n (Sort σ)) (a : forall i, A (ss i)) (i : Fin (pred n)),
+  : forall (ss : FinSeq n (Sort σ)) (a : forall i, A (ss i)) (i : Fin (nat_pred n)),
     A (fstail' n ss i)
   := match n with
      | 0 => fun ss _ i => Empty_rec i
diff --git a/theories/Algebra/Universal/TermAlgebra.v b/theories/Algebra/Universal/TermAlgebra.v
index 09a2cbf76ea..6790ce83742 100644
--- a/theories/Algebra/Universal/TermAlgebra.v
+++ b/theories/Algebra/Universal/TermAlgebra.v
@@ -30,7 +30,7 @@ Inductive CarriersTermAlgebra {σ} (C : Carriers σ) : Carriers σ :=
       DomOperation (CarriersTermAlgebra C) (σ u) ->
       CarriersTermAlgebra C (sort_cod (σ u)).
 
-Scheme CarriersTermAlgebra_ind := Elimination for CarriersTermAlgebra Sort Type.
+Scheme CarriersTermAlgebra_ind := Induction for CarriersTermAlgebra Sort Type.
 Arguments CarriersTermAlgebra_ind {σ}.
 
 Definition CarriersTermAlgebra_rect {σ} := @CarriersTermAlgebra_ind σ.
diff --git a/theories/Analysis/Locator.v b/theories/Analysis/Locator.v
index 4a59dcf04e7..c3b5a8b98f6 100644
--- a/theories/Analysis/Locator.v
+++ b/theories/Analysis/Locator.v
@@ -1,30 +1,21 @@
 Require Import
-        HoTT.Basics
-        HoTT.DProp
-        HoTT.BoundedSearch
-        HoTT.Spaces.Finite.Fin
-        HoTT.ExcludedMiddle.
-
-Require Import
-        HoTT.Classes.interfaces.abstract_algebra
-        HoTT.Classes.interfaces.orders
-        HoTT.Classes.interfaces.rationals
-        HoTT.Classes.interfaces.cauchy
-        HoTT.Classes.interfaces.archimedean
-        HoTT.Classes.interfaces.round
-        HoTT.Classes.interfaces.naturals
-        HoTT.Classes.implementations.peano_naturals
-        HoTT.Classes.orders.archimedean
-        HoTT.Classes.orders.dec_fields
-        HoTT.Classes.orders.lattices
-        HoTT.Classes.theory.apartness
-        HoTT.Classes.theory.rationals.
-
-(* Strangely, it seems that combining the next import with the above list breaks some instance search? *)
-Require Import
-        HoTT.Classes.orders.fields
-        HoTT.Classes.theory.fields
-        HoTT.Classes.theory.dec_fields.
+  Basics DProp BoundedSearch Spaces.Finite.Fin ExcludedMiddle
+  Classes.interfaces.abstract_algebra
+  Classes.interfaces.orders
+  Classes.interfaces.rationals
+  Classes.interfaces.cauchy
+  Classes.interfaces.archimedean
+  Classes.interfaces.round
+  Classes.interfaces.naturals
+  Classes.implementations.peano_naturals
+  Classes.orders.archimedean
+  Classes.orders.dec_fields
+  Classes.orders.lattices
+  Classes.theory.apartness
+  Classes.theory.rationals
+  Classes.orders.fields
+  Classes.theory.fields
+  Classes.theory.dec_fields.
 
 Local Open Scope type_scope.
 
diff --git a/theories/Basics.v b/theories/Basics.v
index 18add73d16a..09f1c866556 100644
--- a/theories/Basics.v
+++ b/theories/Basics.v
@@ -7,6 +7,8 @@ Require Export Basics.Decidable.
 Require Export Basics.Utf8.
 Require Export Basics.Notations.
 Require Export Basics.Tactics.
+Require Export Basics.Classes.
+Require Export Basics.Iff.
 
 Require Export Basics.Nat.
 Require Export Basics.Numeral.
diff --git a/theories/Basics/Classes.v b/theories/Basics/Classes.v
new file mode 100644
index 00000000000..9a56fcbb173
--- /dev/null
+++ b/theories/Basics/Classes.v
@@ -0,0 +1,45 @@
+Require Import Basics.Overture Basics.Tactics.
+
+(** * Classes *)
+
+(** ** Injective Functions *)
+
+Class IsInjective {A B : Type} (f : A -> B)
+  := injective : forall x y, f x = f y -> x = y.
+Arguments injective {A B} f {_} _ _.
+
+Definition neq_isinj {A B : Type} (f : A -> B) `{!IsInjective f}
+  : forall x y, x <> y -> f x <> f y.
+Proof.
+  intros x y np q.
+  apply np, (injective f).
+  exact q.
+Defined.
+
+Global Instance isinj_idmap A : @IsInjective A A idmap
+  := fun x y => idmap.
+
+#[export] Hint Unfold IsInjective : typeclass_instances.
+
+Definition isinj_compose {A B C f g} `{IsInjective B C g} `{IsInjective A B f}
+  : IsInjective (g o f).
+Proof.
+  intros x y p.
+  by apply (injective f), (injective g).
+Defined.
+#[export] Hint Immediate isinj_compose : typeclass_instances.
+
+Definition isinj_cancelL {A B C : Type} (f : A -> B) (g : B -> C)
+  `{!IsInjective (g o f)}
+  : IsInjective f.
+Proof.
+  intros x y p.
+  apply (injective (g o f)).
+  exact (ap g p).
+Defined.
+
+(** ** Antisymmetric Relations *)
+
+Class AntiSymmetric {A : Type} (R : A -> A -> Type) : Type
+  := antisymmetry : forall x y, R x y -> R y x -> x = y.
+Arguments antisymmetry {A} R {AntiSymmetric} x y _ _.
diff --git a/theories/Basics/Datatypes.v b/theories/Basics/Datatypes.v
deleted file mode 100644
index 4830b363ac8..00000000000
--- a/theories/Basics/Datatypes.v
+++ /dev/null
@@ -1,110 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(************************************************************************)
-(*   This file has been modified for the purposes of the HoTT library.  *)
-(************************************************************************)
-
-Set Implicit Arguments.
-
-Require Import Basics.Logic.
-
-Global Set Primitive Projections.
-Global Set Nonrecursive Elimination Schemes.
-Local Unset Elimination Schemes.
-
-Local Set Polymorphic Inductive Cumulativity.
-
-(** [option A] is the extension of [A] with an extra element [None] *)
-
-Inductive option (A : Type) : Type :=
-  | Some : A -> option A
-  | None : option A.
-
-Scheme option_rect := Induction for option Sort Type.
-
-Arguments Some {A} a.
-Arguments None {A}.
-
-Register option as core.option.type.
-
-(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)
-
-Inductive sum (A B : Type) : Type :=
-  | inl : A -> sum A B
-  | inr : B -> sum A B.
-
-Scheme sum_rect := Induction for sum Sort Type.
-
-Notation "x + y" := (sum x y) : type_scope.
-
-Arguments inl {A B} _ , [A] B _.
-Arguments inr {A B} _ , A [B] _.
-
-(* A notation for coproduct that's less overloaded than [+] *)
-Notation "x |_| y" := (sum x y) (only parsing) : type_scope.
-
-(** [prod A B], written [A * B], is the product of [A] and [B];
-    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)
-
-Record prod (A B : Type) := pair { fst : A ; snd : B }.
-
-Scheme prod_rect := Induction for prod Sort Type.
-
-Arguments pair {A B} _ _.
-Arguments fst {A B} _ / .
-Arguments snd {A B} _ / .
-
-Add Printing Let prod.
-
-Notation "x * y" := (prod x y) : type_scope.
-Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
-Notation "A /\ B" := (prod A B) (only parsing) : type_scope.
-Notation and := prod (only parsing).
-Notation conj := pair (only parsing).
-
-#[export] Hint Resolve pair inl inr : core.
-
-Definition prod_curry (A B C : Type) (f : A -> B -> C)
-  (p : prod A B) : C := f (fst p) (snd p).
-
-(** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)
-
-Definition iff (A B : Type) := prod (A -> B) (B -> A).
-
-Notation "A <-> B" := (iff A B) : type_scope.
-
-(** Another way of interpreting booleans as propositions *)
-
-(* Definition is_true b := b = true. *)
-
-(** Polymorphic lists and some operations *)
-
-Inductive list (A : Type) : Type :=
- | nil : list A
- | cons : A -> list A -> list A.
-
-Scheme list_rect := Induction for list Sort Type.
-
-Arguments nil {A}.
-Declare Scope list_scope.
-Infix "::" := cons : list_scope.
-Delimit Scope list_scope with list.
-Bind Scope list_scope with list.
-
-Local Open Scope list_scope.
-(** Concatenation of two lists *)
-
-Definition app (A : Type) : list A -> list A -> list A :=
-  fix app l m :=
-  match l with
-   | nil => m
-   | a :: l1 => a :: app l1 m
-  end.
-
-Infix "++" := app : list_scope.
diff --git a/theories/Basics/Decidable.v b/theories/Basics/Decidable.v
index fe4d7927216..2f7614351f3 100644
--- a/theories/Basics/Decidable.v
+++ b/theories/Basics/Decidable.v
@@ -3,7 +3,8 @@ Require Import
   Basics.Overture
   Basics.PathGroupoids
   Basics.Trunc
-  Basics.Tactics.
+  Basics.Tactics
+  Basics.Iff.
 Local Open Scope trunc_scope.
 Local Open Scope path_scope.
 
@@ -27,10 +28,45 @@ Ltac decide_type A :=
   end.
 
 Ltac decide :=
-  match goal with
+  multimatch goal with
   | [|- ?A] => decide_type A
+  | [|- ~ ?A] => decide_type A
   end.
 
+Definition decidable_true {A : Type} `{Decidable A}
+  (a : A)
+  (P : forall (p : Decidable A), Type)
+  (p : forall x, P (inl x))
+  : forall p, P p.
+Proof.
+  intros [x|n].
+  - apply p.
+  - contradiction n.
+Defined.
+
+(** Replace a term [p] of the form [Decidable A] with [inl x] if we have a term [a : A] showing that [A] is true. *)
+Ltac decidable_true p a :=
+  generalize p;
+  rapply (decidable_true a);
+  try intro.
+
+Definition decidable_false {A : Type} `{Decidable A}
+  (n : not A)
+  (P : forall (p : Decidable A), Type)
+  (p : forall n', P (inr n'))
+  : forall p, P p.
+Proof.
+  intros [x|n'].
+  - contradiction n.
+  - apply p.
+Defined.
+
+(** Replace a term [p] of the form [Decidable A] with [inr na] if we have a term [n : not A] showing that [A] is false. *)
+Ltac decidable_false p n :=
+  generalize p;
+  rapply (decidable_false n);
+  try intro.
+
 Class DecidablePaths (A : Type) :=
   dec_paths : forall (x y : A), Decidable (x = y).
 Global Existing Instance dec_paths.
@@ -50,6 +86,13 @@ Proof.
   exact (nnnp (fun np => np p)).
 Defined.
 
+Definition iff_stable P `(Stable P) : ~~P <-> P.
+Proof.
+  split.
+  - apply stable.
+  - exact (fun x f => f x).
+Defined.
+
 (**
   Because [vm_compute] evaluates terms in [PROP] eagerly
   and does not remove dead code we
@@ -87,17 +130,21 @@ Global Instance decidable_empty : Decidable Empty
 
 (** ** Transfer along equivalences *)
 
-Definition decidable_equiv (A : Type) {B : Type} (f : A -> B) `{IsEquiv A B f}
-: Decidable A -> Decidable B.
+Definition decidable_iff {A B} (f : A <-> B)
+  : Decidable A -> Decidable B.
 Proof.
   intros [a|na].
-  - exact (inl (f a)).
-  - exact (inr (fun b => na (f^-1 b))).
+  - exact (inl (fst f a)).
+  - exact (inr (fun b => na (snd f b))).
 Defined.
 
 Definition decidable_equiv' (A : Type) {B : Type} (f : A <~> B)
 : Decidable A -> Decidable B
-  := decidable_equiv A f.
+  := decidable_iff f.
+
+Definition decidable_equiv (A : Type) {B : Type} (f : A -> B) `{!IsEquiv f}
+: Decidable A -> Decidable B
+  := decidable_equiv' _ (Build_Equiv _ _ f _).
 
 Definition decidablepaths_equiv
            (A : Type) {B : Type} (f : A -> B) `{IsEquiv A B f}
@@ -181,12 +228,27 @@ Proof.
   intros x y; apply collapsible_hprop; exact _.
 Defined.
 
+(** Hedberg's Theorem *)
 Corollary hset_decpaths (A : Type) `{DecidablePaths A}
 : IsHSet A.
 Proof.
   exact _.
 Defined.
 
+(** We can use Hedberg's Theorem to simplify a goal of the form [forall (d : Decidable (x = x :> A)), P d] when [A] has decidable paths. *)
+Definition decidable_paths_refl (A : Type) `{DecidablePaths A}
+  (x : A)
+  (P : forall (d : Decidable (x = x)), Type)
+  (Px : P (inl idpath))
+  : forall d, P d.
+Proof.
+  rapply (decidable_true idpath).
+  intro p.
+  (** We cannot eliminate [p : x = x] with path induction, but we can use Hedberg's theorem to replace this with [idpath]. *)
+  assert (r : (idpath = p)) by apply path_ishprop.
+  by destruct r.
+Defined.
+
 (** ** Truncation *)
 
 (** Having decidable equality (which implies being an hset, by Hedberg's theorem above) is itself an hprop. *)
@@ -207,3 +269,37 @@ Proof.
   - elim (nd d').
   - apply ap, path_forall; intros p; elim (nd p).
 Defined.
+
+(** ** Logical Laws *)
+
+(** Various logical laws don't hold constructively as they do classically due to a required use of excluded middle. For us, this means that some laws require further assumptions on the decidability of propositions. *)
+
+(** Here we give the dual De Morgan's Law which complements the one given in Iff.v.  One direction requires that one of the two propositions be decidable, while the other direction needs no assumption.  We state the latter property first, to avoid duplication in the proof. *)
+Definition not_prod_sum_not A B : ~ A + ~ B -> ~ (A * B).
+Proof.
+  intros [na|nb] [a b].
+  - exact (na a).
+  - exact (nb b).
+Defined.
+
+Definition iff_not_prod A B `{Decidable A}
+  : ~ (A * B) <-> ~ A + ~ B.
+Proof.
+  split.
+  - intros np.
+    destruct (dec A) as [a|na].
+    + exact (inr (fun b => np (a, b))).
+    + exact (inl na).
+  - apply not_prod_sum_not.
+Defined.
+
+Definition iff_not_prod' A B `{Decidable B}
+  : ~ (A * B) <-> ~ A + ~ B.
+Proof.
+  split.
+  - intros np.
+    destruct (dec B) as [b|nb].
+    + exact (inl (fun a => np (a, b))).
+    + exact (inr nb).
+  - apply not_prod_sum_not.
+Defined.
diff --git a/theories/Basics/Equivalences.v b/theories/Basics/Equivalences.v
index 433c65c9d7a..9384495d478 100644
--- a/theories/Basics/Equivalences.v
+++ b/theories/Basics/Equivalences.v
@@ -80,9 +80,6 @@ Ltac change_apply_equiv_compose :=
     change ((f oE g) x) with (f (g x))
   end.
 
-Definition iff_equiv {A B : Type} (f : A <~> B)
-  : A <-> B := (equiv_fun f, f^-1).
-
 (** Transporting is an equivalence. *)
 Section EquivTransport.
 
@@ -133,8 +130,8 @@ Section Adjointify.
 
 End Adjointify.
 
-Arguments isequiv_adjointify {A B}%type_scope (f g)%function_scope isretr issect.
-Arguments equiv_adjointify {A B}%type_scope (f g)%function_scope isretr issect.
+Arguments isequiv_adjointify {A B}%_type_scope (f g)%_function_scope isretr issect.
+Arguments equiv_adjointify {A B}%_type_scope (f g)%_function_scope isretr issect.
 
 (** Anything homotopic to an equivalence is an equivalence. This should not be an instance; it can cause the unifier to spin forever searching for functions to be homotopic to. *)
 Definition isequiv_homotopic {A B : Type} (f : A -> B) {g : A -> B}
@@ -283,7 +280,7 @@ Definition equiv_ap `(f : A -> B) `{IsEquiv A B f} (x y : A)
   : (x = y) <~> (f x = f y)
   := Build_Equiv _ _ (ap f) _.
 
-Global Arguments equiv_ap (A B)%type_scope f%function_scope _ _ _.
+Global Arguments equiv_ap (A B)%_type_scope f%_function_scope _ _ _.
 
 Definition equiv_ap' `(f : A <~> B) (x y : A)
   : (x = y) <~> (f x = f y)
@@ -574,10 +571,10 @@ Ltac ev_equiv :=
 
 (** The following tactic [make_equiv] builds an equivalence between two types built out of arbitrarily nested sigma and record types, not necessarily right-associated, as long as they have all the same underyling components.  This is more general than [issig] in that it doesn't just prove equivalences between a single record type and a single right-nested tower of sigma types, but less powerful in that it can't deduce the latter nested tower of sigmas automatically: you have to have both sides of the equivalence known. *)
 
-(* Perform [intros] repeatedly, recursively destructing all possibly-nested record types. We use a custom induction principle for [Contr], since [elim] produces two goals. *)
+(* Perform [intros] repeatedly, recursively destructing all possibly-nested record types. We use a custom induction principle for [Contr], since [elim] produces two goals. The [hnf] is important, for example to unfold [IsUnitPreserving] to an equality, which the [lazymatch] then ignores. *)
 Ltac decomposing_intros :=
   let x := fresh in
-  intros x; cbn in x;
+  intros x; hnf in x; cbn in x;
   try lazymatch type of x with
   | ?a = ?b => idtac           (** Don't destruct paths *)
   | forall y:?A, ?B => idtac   (** Don't apply functions *)
@@ -750,7 +747,7 @@ Defined.
 (** We start with a version of [decomposing_intros] that is willing to destruct paths, though as a second choice. *)
 Ltac decomposing_intros_with_paths :=
   let x := fresh in
-  intros x; cbn in x;
+  intros x; hnf in x; cbn in x;
   multimatch type of x with
   | _ =>
     try match type of x with
diff --git a/theories/Basics/Iff.v b/theories/Basics/Iff.v
new file mode 100644
index 00000000000..bcc53a624c1
--- /dev/null
+++ b/theories/Basics/Iff.v
@@ -0,0 +1,60 @@
+Require Import Basics.Overture Basics.Tactics.
+
+Local Set Universe Minimization ToSet.
+
+(** * If and only if *)
+
+(** ** Definition *)
+
+(** [iff A B], written [A <-> B], expresses the logical equivalence of [A] and [B] *)
+Definition iff (A B : Type) := prod (A -> B) (B -> A).
+
+Notation "A <-> B" := (iff A B) : type_scope.
+
+(** ** Basic Properties *)
+
+(** Everything is logically equivlaent to itself. *)
+Definition iff_refl {A} : A <-> A
+  := (idmap , idmap).
+
+(** [iff] is a reflexive relation. *)
+Global Instance iff_reflexive : Reflexive iff | 1
+  := @iff_refl.
+
+(** Logical equivalences can be inverted. *)
+Definition iff_inverse {A B} : (A <-> B) -> (B <-> A)
+  :=  fun f => (snd f , fst f).
+
+(** [iff] is a symmetric relation. *)
+Global Instance symmetric_iff : Symmetric iff | 1
+  := @iff_inverse.
+
+(** Logical equivalences can be composed. *)
+Definition iff_compose {A B C} (f : A <-> B) (g : B <-> C) : A <-> C
+  := (fst g o fst f , snd f o snd g).
+
+(** [iff] is a transitive relation. *)
+Global Instance transitive_iff : Transitive iff | 1
+  := @iff_compose.
+
+(** Any equivalence can be considered a logical equivalence by discarding everything but the maps. We make this a coercion so that equivalences can be used in place of logical equivalences. *)
+Coercion iff_equiv {A B : Type} (f : A <~> B)
+  : A <-> B := (equiv_fun f, f^-1).
+
+(** ** Logical Laws *)
+
+(** One of De Morgan's Laws.  The dual statement about negating a product appears in Decidable.v due to decidability requirements. *)
+Definition iff_not_sum A B : ~ (A + B) <-> ~ A * ~ B.
+Proof.
+  split.
+  - intros ns.
+    exact (ns o inl, ns o inr).
+  - by intros []; snrapply sum_ind.
+Defined.
+
+Definition iff_contradiction A : A * ~A <-> Empty.
+Proof.
+  split.
+  - intros [a na]; exact (na a).
+  - intros e; exact (Empty_rec _ e).
+Defined.
diff --git a/theories/Basics/Logic.v b/theories/Basics/Logic.v
deleted file mode 100644
index e6956522a71..00000000000
--- a/theories/Basics/Logic.v
+++ /dev/null
@@ -1,31 +0,0 @@
-(************************************************************************)
-(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
-(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012     *)
-(*   \VV/  **************************************************************)
-(*    //   *      This file is distributed under the terms of the       *)
-(*         *       GNU Lesser General Public License Version 2.1        *)
-(************************************************************************)
-
-(************************************************************************)
-(*   This file has been modified for the purposes of the HoTT library.  *)
-(************************************************************************)
-
-Set Implicit Arguments.
-
-Require Export Basics.Notations.
-
-Global Set Universe Polymorphism.
-Global Set Asymmetric Patterns.
-
-Notation "A -> B" := (forall (_ : A), B) : type_scope.
-
-(** [True] is the unit type. *)
-Inductive True : Set :=
-  I : True.
-
-(** [False] is the empty type. *)
-Inductive False : Set :=.
-
-#[export] Hint Resolve I : core.
-
-(* In the HoTT library, we generally avoid using [True] and [False] and instead use [Unit] and [Empty]. *)
diff --git a/theories/Basics/Nat.v b/theories/Basics/Nat.v
index 973a18118c1..7ad83359571 100644
--- a/theories/Basics/Nat.v
+++ b/theories/Basics/Nat.v
@@ -110,8 +110,8 @@ Definition to_int n := Decimal.Pos (to_uint n).
 
 Definition to_num_int n := Numeral.IntDec (to_int n).
 
-Arguments of_uint d%dec_uint_scope.
-Arguments of_int d%dec_int_scope.
+Arguments of_uint d%_dec_uint_scope.
+Arguments of_int d%_dec_int_scope.
 
 (* Parsing / printing of [nat] numbers *)
 Number Notation nat of_num_uint to_num_uint (abstract after 5001) : nat_scope.
diff --git a/theories/Basics/Notations.v b/theories/Basics/Notations.v
index acf3f48e884..0ccd5b0aefb 100644
--- a/theories/Basics/Notations.v
+++ b/theories/Basics/Notations.v
@@ -1,3 +1,7 @@
+(** [type_scope] must be declared and bound early on so that later reserved notations register correctly. *)
+Declare Scope type_scope.
+Bind Scope type_scope with Sortclass.
+
 (** To reserve this notation, we must first bootstrap, and preserve the underlying [forall] notation *)
 Notation "'forall'  x .. y , P" := (forall x , .. (forall y, P) ..) (at level 200, x binder, y binder, right associativity).
 Reserved Notation "'exists' x .. y , p"
@@ -8,10 +12,6 @@ Reserved Notation "'exists' x .. y , p"
 (** Work around bug 5569, https://coq.inria.fr/bugs/show_bug.cgi?id=5569, Warning skip-spaces-curly,parsing seems bogus *)
 Local Set Warnings Append "-skip-spaces-curly".
 
-(** ML Tactic Notations *)
-Declare ML Module "ltac_plugin".
-Global Set Default Proof Mode "Classic".
-
 (** These are the notations whose level and associativity are imposed by Coq *)
 
 (** Notations for propositional connectives *)
@@ -50,7 +50,7 @@ Reserved Notation "x < y <= z" (at level 70, y at next level).
 Reserved Notation "x + y" (at level 50, left associativity).
 Reserved Notation "x - y" (at level 50, left associativity).
 Reserved Notation "x * y" (at level 40, left associativity).
-Reserved Notation "x / y" (at level 40, left associativity).
+Reserved Notation "x / y" (at level 40, no associativity).
 Reserved Notation "- x" (at level 35, right associativity).
 Reserved Notation "/ x" (at level 35, right associativity).
 Reserved Notation "x ^ y" (at level 30, right associativity).
@@ -84,17 +84,17 @@ Reserved Notation "{ x : A  & P  & Q }" (at level 0, x at level 99).
 
  
 (** Numeric *)
-Reserved Notation "n .+1" (at level 2, left associativity, format "n .+1").
-Reserved Notation "n .+2" (at level 2, left associativity, format "n .+2").
-Reserved Notation "n .+3" (at level 2, left associativity, format "n .+3").
-Reserved Notation "n .+4" (at level 2, left associativity, format "n .+4").
-Reserved Notation "n .+5" (at level 2, left associativity, format "n .+5").
-Reserved Notation "n '.-1'" (at level 2, left associativity, format "n .-1").
-Reserved Notation "n '.-2'" (at level 2, left associativity, format "n .-2").
+Reserved Notation "n .+1" (at level 1, left associativity, format "n .+1").
+Reserved Notation "n .+2" (at level 1, left associativity, format "n .+2").
+Reserved Notation "n .+3" (at level 1, left associativity, format "n .+3").
+Reserved Notation "n .+4" (at level 1, left associativity, format "n .+4").
+Reserved Notation "n .+5" (at level 1, left associativity, format "n .+5").
+Reserved Notation "n '.-1'" (at level 1, left associativity, format "n .-1").
+Reserved Notation "n '.-2'" (at level 1, left associativity, format "n .-2").
 Reserved Notation "m +2+ n" (at level 50, left associativity).
 Reserved Infix "mod" (at level 40, no associativity).
-Reserved Notation "p ~ 1" (at level 7, left associativity, format "p '~' '1'").
-Reserved Notation "p ~ 0" (at level 7, left associativity, format "p '~' '0'").
+Reserved Notation "p ~ 1" (at level 1, left associativity, format "p '~' '1'").
+Reserved Notation "p ~ 0" (at level 1, left associativity, format "p '~' '0'").
 
 (** Pointed *)
 Reserved Infix "@*" (at level 30).
@@ -104,19 +104,19 @@ Reserved Infix "->*" (at level 99).
 Reserved Infix "->**" (at level 99).
 Reserved Infix "o*" (at level 40, left associativity).
 Reserved Infix "==*" (at level 70, no associativity).
-Reserved Notation "g ^*'" (at level 20).
-Reserved Notation "f ^*" (at level 3, format "f '^*'").
-Reserved Notation "f ^-1*" (at level 3, format "f '^-1*'").
+Reserved Notation "g ^*'" (at level 1).
+Reserved Notation "f ^*" (at level 1, format "f '^*'").
+Reserved Notation "f ^-1*" (at level 1, format "f '^-1*'").
 Reserved Notation "g o*E f" (at level 40, left associativity).
 Reserved Notation "'ppforall'  x .. y , P"
      (at level 200, x binder, y binder, right associativity).
 
 (** Sigma type *)
-Reserved Notation "x .1" (at level 3, format "x '.1'").
-Reserved Notation "x .2" (at level 3, format "x '.2'").
+Reserved Notation "x .1" (at level 1, format "x '.1'").
+Reserved Notation "x .2" (at level 1, format "x '.2'").
 
 (** Paths *)
-Reserved Notation "p ^" (at level 3, format "p '^'").
+Reserved Notation "p ^" (at level 1, format "p '^'").
 Reserved Notation "p @ q" (at level 20).
 Reserved Notation "p # x" (right associativity, at level 65).
 Reserved Notation "p # x" (right associativity, at level 65).
@@ -127,8 +127,7 @@ Reserved Notation "f == g" (at level 70, no associativity).
 
 (** Equivalences *)
 Reserved Notation "A <~> B" (at level 85).
-Reserved Notation "f ^-1" (at level 3, format "f '^-1'").
-Reserved Notation "m ^-1" (at level 3, format "m '^-1'").
+Reserved Notation "f ^-1" (at level 1, format "f '^-1'").
 Reserved Notation "g 'oE' f" (at level 40, left associativity).
 Reserved Notation "f *E g" (at level 40, left associativity).
 Reserved Notation "f +E g" (at level 50, left associativity).
@@ -136,11 +135,11 @@ Reserved Notation "f +E g" (at level 50, left associativity).
 (** Categories *)
 Reserved Infix "-|" (at level 60, right associativity).
 Reserved Infix "<~=~>" (at level 70, no associativity).
-Reserved Notation "a // 'CAT'" (at level 40, left associativity).
-Reserved Notation "a \\ 'CAT'" (at level 40, left associativity).
+Reserved Notation "a // 'CAT'" (at level 1, left associativity).
+Reserved Notation "a \\ 'CAT'" (at level 1, left associativity).
 Reserved Notation "'CAT' // a" (at level 40, left associativity).
 Reserved Notation "'CAT' \\ a" (at level 40, left associativity).
-Reserved Notation "C ^op" (at level 3, format "C '^op'").
+Reserved Notation "C ^op" (at level 1, format "C '^op'").
 
 (** Universal algebra *)
 Reserved Notation "u .# A" (at level 3, format "u '.#' A").
@@ -160,17 +159,17 @@ Reserved Infix "$@L" (at level 30).
 Reserved Infix "$@R" (at level 30).
 Reserved Infix "$@@" (at level 30).
 Reserved Infix "$=>" (at level 99).
-Reserved Notation "T ^op" (at level 3, format "T ^op").
-Reserved Notation "f ^-1$" (at level 3, format "f '^-1$'").
-Reserved Notation "f ^$" (at level 3, format "f '^$'").
+Reserved Notation "T ^op" (at level 1, format "T ^op").
+Reserved Notation "f ^-1$" (at level 1, format "f '^-1$'").
+Reserved Notation "f ^$" (at level 1, format "f '^$'").
 Reserved Infix "$@h" (at level 35).
 Reserved Infix "$@v" (at level 35).
 Reserved Infix "$@hR" (at level 34).
 Reserved Infix "$@hL" (at level 34).
 Reserved Infix "$@vR" (at level 34).
 Reserved Infix "$@vL" (at level 34).
-Reserved Notation "s ^h$" (at level 20).
-Reserved Notation "s ^v$" (at level 20).
+Reserved Notation "s ^h$" (at level 1).
+Reserved Notation "s ^v$" (at level 1).
 
 (** Displayed wild cat *)
 Reserved Infix "$o'" (at level 40, left associativity).
@@ -179,8 +178,8 @@ Reserved Infix "$@L'" (at level 30).
 Reserved Infix "$@R'" (at level 30).
 Reserved Infix "$@@'" (at level 30).
 Reserved Infix "$oE'" (at level 40, left associativity).
-Reserved Notation "f ^$'" (at level 3, format "f '^$''").
-Reserved Notation "f ^-1$'" (at level 3, format "f '^-1$''").
+Reserved Notation "f ^$'" (at level 1, format "f '^$''").
+Reserved Notation "f ^-1$'" (at level 1, format "f '^-1$''").
 
 (** Cubical *)
 Reserved Infix "@@h" (at level 30).
@@ -189,11 +188,17 @@ Reserved Infix "@lr" (at level 30).
 Reserved Notation "x '@Dp' y"  (at level 20).
 Reserved Notation "x '@Dr' y" (at level 20).
 Reserved Notation "x '@Dl' y" (at level 20).
-Reserved Notation "x '^D'" (at level 3).
+Reserved Notation "x '^D'" (at level 1).
 
 (** Lists *)
 Reserved Infix "::" (at level 60, right associativity).
 Reserved Infix "++" (right associativity, at level 60).
+Reserved Notation "[ u ]" (at level 0).
+Reserved Notation " [ u , v ] " (at level 0).
+
+(** Algebra *)
+Reserved Infix "*L" (at level 40).
+Reserved Infix "*R" (at level 40).
 
 (** Other / Not sorted yet *)
 
@@ -213,18 +218,16 @@ Reserved Notation "D '_f' g" (at level 10).
 Reserved Notation "F '_0' x" (at level 10, no associativity).
 Reserved Notation "F '_0' x" (at level 10, no associativity).
 Reserved Notation "F '_1' m" (at level 10, no associativity).
-Reserved Notation "F ^op" (at level 3, format "F ^op").
+Reserved Notation "F ^op" (at level 1, format "F ^op").
 Reserved Notation "'forall'  x .. y , P" (at level 200, x binder, y binder, right associativity).
 Reserved Notation "g 'oD' f" (at level 40, left associativity).
 Reserved Notation "g 'o' f" (at level 40, left associativity).
 Reserved Notation "m <= n" (at level 70, no associativity).
 Reserved Notation "n -Type" (at level 1).
-Reserved Notation "p ..1" (at level 3).
-Reserved Notation "p ..2" (at level 3).
+Reserved Notation "p ..1" (at level 1).
+Reserved Notation "p ..2" (at level 1).
 Reserved Notation "!! P" (at level 35, right associativity).
-Reserved Notation "[ u ]" (at level 9).
 Reserved Notation "u ~~ v" (at level 30).
-Reserved Notation " [ u , v ] " (at level 9).
 Reserved Notation "! x" (at level 3, format "'!' x").
 Reserved Notation "x \\ F" (at level 40, left associativity).
 Reserved Notation "x // F" (at level 40, left associativity).
@@ -238,16 +241,16 @@ Reserved Notation "x (-> y" (at level 99, right associativity, y at level 200).
 Reserved Notation "x <> y  :>  T" (at level 70, y at next level, no associativity).
 Reserved Notation "Z ** W" (at level 30, right associativity).
 
-Reserved Notation "'+N'" (at level 55).
-Reserved Notation "'+Z'" (at level 55).
-Reserved Notation "'N3'" (at level 55).
-Reserved Notation "'Z3'" (at level 55).
+Reserved Notation "'+N'" (at level 0).
+Reserved Notation "'+Z'" (at level 0).
+Reserved Notation "'N3'" (at level 0).
+Reserved Notation "'Z3'" (at level 0).
 
-Reserved Notation "a ^+" (at level 0).
-Reserved Notation "a ^+ k" (at level 0).
-Reserved Notation "x ^++" (at level 0).
-Reserved Notation "x ^++ k" (at level 0).
-Reserved Notation "b ^+f" (at level 0).
+Reserved Notation "a ^+" (at level 1).
+Reserved Notation "a ^+ k" (at level 1).
+Reserved Notation "x ^++" (at level 1).
+Reserved Notation "x ^++ k" (at level 1).
+Reserved Notation "b ^+f" (at level 1).
 
 (** Mathclasses *)
 Reserved Notation "' x" (at level 20).
@@ -266,7 +269,6 @@ Reserved Infix ":::" (at level 60, right associativity).
 (** We define various scopes and open them in the order we expect to use them. *)
 Declare Scope core_scope.
 Declare Scope function_scope.
-Declare Scope type_scope.
 Declare Scope equiv_scope.
 Declare Scope path_scope.
 Declare Scope fibration_scope.
@@ -291,4 +293,3 @@ Global Open Scope type_scope.
 Global Open Scope core_scope.
 
 Bind Scope function_scope with Funclass.
-Bind Scope type_scope with Sortclass.
diff --git a/theories/Basics/Numeral.v b/theories/Basics/Numeral.v
index ba432af5c13..ae05ceb38ef 100644
--- a/theories/Basics/Numeral.v
+++ b/theories/Basics/Numeral.v
@@ -1,4 +1,4 @@
-Require Import Basics.Overture Basics.Hexadecimal.
+Require Import Basics.Overture Basics.Numerals.Decimal Basics.Numerals.Hexadecimal.
 
 (** * Decimal or Hexadecimal numbers *)
 
diff --git a/theories/Basics/Decimal.v b/theories/Basics/Numerals/Decimal.v
similarity index 100%
rename from theories/Basics/Decimal.v
rename to theories/Basics/Numerals/Decimal.v
diff --git a/theories/Basics/Hexadecimal.v b/theories/Basics/Numerals/Hexadecimal.v
similarity index 99%
rename from theories/Basics/Hexadecimal.v
rename to theories/Basics/Numerals/Hexadecimal.v
index 3fbc10c1153..03bd98d9882 100644
--- a/theories/Basics/Hexadecimal.v
+++ b/theories/Basics/Numerals/Hexadecimal.v
@@ -12,7 +12,7 @@
 (* This file has been modified for use in the HoTT library              *)
 (************************************************************************)
 
-Require Import Basics.Overture Basics.Decimal.
+Require Import Basics.Overture Basics.Numerals.Decimal.
 
 (** * Hexadecimal numbers *)
 
diff --git a/theories/Basics/Overture.v b/theories/Basics/Overture.v
index 75cd893cc58..779cda59d5e 100644
--- a/theories/Basics/Overture.v
+++ b/theories/Basics/Overture.v
@@ -2,50 +2,81 @@
 
 (** * Basic definitions of homotopy type theory, particularly the groupoid structure of identity types. *)
 (** Import the file of reserved notations so we maintain consistent level notations throughout the library *)
-Require Export Basics.Notations Basics.Datatypes Basics.Logic.
+Require Export Basics.Settings Basics.Notations.
 
-Declare ML Module "number_string_notation_plugin".
+Local Set Polymorphic Inductive Cumulativity.
 
-(** Keywords for blacklisting from search function *)
-Add Search Blacklist "_admitted" "_subproof" "Private_".
+(** This command prevents Coq from automatically defining the eliminator functions for inductive types.  We will define them ourselves to match the naming scheme of the HoTT Book.  In principle we ought to make this [Global], but unfortunately the tactics [induction] and [elim] assume that the eliminators are named in Coq's way, e.g. [thing_rect], so making it global could cause unpleasant surprises for people defining new inductive types.  However, when you do define your own inductive types you are encouraged to also do [Local Unset Elimination Schemes] and then use [Scheme] to define [thing_ind], [thing_rec], and (for compatibility with [induction] and [elim]) [thing_rect], as we have done below for [paths], [Empty], [Unit], etc.  We are hoping that this will be fixed eventually; see https://github.com/coq/coq/issues/3745.  *)
+Local Unset Elimination Schemes.
 
-Create HintDb rewrite discriminated.
-#[export] Hint Variables Opaque : rewrite.
-Create HintDb typeclass_instances discriminated.
+(** ** Datatypes *)
 
-Local Set Polymorphic Inductive Cumulativity.
+(** *** Functions *)
 
-(** Disable warning about argument scope delimiters. TODO: remove this once we bump the minimal Coq version to 8.19 and merge #1862. *)
-Global Set Warnings "-argument-scope-delimiter".
+(** Notation for non-dependent function types *)
+Notation "A -> B" := (forall (_ : A), B) : type_scope.
 
-(** ** Type classes *)
+(** *** Option type *)
 
-(** This command prevents Coq from trying to guess the values of existential variables while doing typeclass resolution.  If you don't know what that means, ignore it. *)
-Local Set Typeclasses Strict Resolution.
+(** [option A] is the extension of [A] with an extra element [None] *)
+Inductive option (A : Type) : Type :=
+  | Some : A -> option A
+  | None : option A.
 
-(** This command prevents Coq from automatically defining the eliminator functions for inductive types.  We will define them ourselves to match the naming scheme of the HoTT Book.  In principle we ought to make this [Global], but unfortunately the tactics [induction] and [elim] assume that the eliminators are named in Coq's way, e.g. [thing_rect], so making it global could cause unpleasant surprises for people defining new inductive types.  However, when you do define your own inductive types you are encouraged to also do [Local Unset Elimination Schemes] and then use [Scheme] to define [thing_ind], [thing_rec], and (for compatibility with [induction] and [elim]) [thing_rect], as we have done below for [paths], [Empty], [Unit], etc.  We are hoping that this will be fixed eventually; see https://github.com/coq/coq/issues/3745.  *)
-Local Unset Elimination Schemes.
+Scheme option_rect := Induction for option Sort Type.
+
+Arguments Some {A} a.
+Arguments None {A}.
+
+Register option as core.option.type.
+
+(** *** Sum type *)
+
+(** [sum A B], written [A + B], is the disjoint sum of [A] and [B] *)
+Inductive sum (A B : Type) : Type :=
+  | inl : A -> sum A B
+  | inr : B -> sum A B.
+
+Scheme sum_rect := Induction for sum Sort Type.
+Scheme sum_ind := Induction for sum Sort Type.
+Arguments sum_ind {A B} P f g : rename.
+
+Notation "x + y" := (sum x y) : type_scope.
+
+Arguments inl {A B} _ , [A] B _.
+Arguments inr {A B} _ , A [B] _.
 
-(** This command changes Coq's subterm selection to always use full conversion after finding a subterm whose head/key matches the key of the term we're looking for.  This applies to [rewrite] and higher-order unification in [apply]/[elim]/[destruct].  Again, if you don't know what that means, ignore it. *)
-Global Set Keyed Unification.
+(* A notation for coproduct that's less overloaded than [+] *)
+Notation "x |_| y" := (sum x y) (only parsing) : type_scope.
 
-(** This command makes it so that you don't have to declare universes explicitly when mentioning them in the type.  (Without this command, if you want to say [Definition foo := Type@{i}.], you must instead say [Definition foo@{i} := Type@{i}.]. *)
-Global Unset Strict Universe Declaration.
+(** *** Product type *)
 
-(** This command makes it so that when we say something like [IsHSet nat] we get [IsHSet@{i} nat] instead of [IsHSet@{Set} nat]. *)
-Global Unset Universe Minimization ToSet.
+(** [prod A B], written [A * B], is the product of [A] and [B];
+    the pair [pair A B a b] of [a] and [b] is abbreviated [(a,b)] *)
+Record prod (A B : Type) := pair { fst : A ; snd : B }.
 
-(** Force to use bullets in proofs. *)
-Global Set Default Goal Selector "!".
+Scheme prod_rect := Induction for prod Sort Type.
+Scheme prod_ind := Induction for prod Sort Type.
+Arguments prod_ind {A B} P _. 
 
-(** Currently Coq doesn't print equivalences correctly (8.6). This fixes that. See https://github.com/HoTT/HoTT/issues/1000 *)
-Global Set Printing Primitive Projection Parameters.
+Arguments pair {A B} _ _.
+Arguments fst {A B} _ / .
+Arguments snd {A B} _ / .
 
-(** This tells Coq that when we [Require] a module without [Import]ing it, typeclass instances defined in that module should also not be imported.  In other words, the only effect of [Require] without [Import] is to make qualified names available. *)
-Global Set Loose Hint Behavior "Strict".
+Add Printing Let prod.
 
-(** Apply using the same opacity information as typeclass proof search. *)
-Ltac class_apply c := autoapply c with typeclass_instances.
+Notation "x * y" := (prod x y) : type_scope.
+Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope.
+Notation "A /\ B" := (prod A B) (only parsing) : type_scope.
+Notation and := prod (only parsing).
+Notation conj := pair (only parsing).
+
+#[export] Hint Resolve pair inl inr : core.
+
+(** ** Type classes *)
+
+(** This command prevents Coq from trying to guess the values of existential variables while doing typeclass resolution.  If you don't know what that means, ignore it. *)
+Local Set Typeclasses Strict Resolution.
 
 Definition Relation (A : Type) := A -> A -> Type.
 
@@ -134,11 +165,11 @@ Arguments sig_ind {_ _}.
 
 (** We make the parameters maximally inserted so that we can pass around [pr1] as a function and have it actually mean "first projection" in, e.g., [ap]. *)
 
-Arguments exist {A}%type P%type _ _.
+Arguments exist {A}%_type P%_type _ _.
 Arguments proj1 {A P} _ / .
 Arguments proj2 {A P} _ / .
 
-Arguments sig (A P)%type.
+Arguments sig (A P)%_type.
 
 Notation "{ x | P }" := (sig (fun x => P)) : type_scope.
 Notation "{ x : A | P }" := (sig (A := A) (fun x => P)) : type_scope.
@@ -147,6 +178,12 @@ Notation "{ x : A  & P }" := (sig (fun x:A => P)) : type_scope.
 
 (** This lets us pattern match sigma types in let expressions *)
 Add Printing Let sig.
+  
+Register sig as core.sigT.type.
+Register exist as core.sigT.intro.
+Register sig_rect as core.sigT.rect.
+Register proj1 as core.sigT.proj1.
+Register proj2 as core.sigT.proj2.
 
 #[export] Hint Resolve exist : core.
 
@@ -165,6 +202,8 @@ Notation "x .2" := (pr2 x) : fibration_scope.
 
 Definition uncurry {A B C} (f : A -> B -> C) (p : A * B) : C := f (fst p) (snd p).
 
+Arguments uncurry {A B C} f%_function_scope p /. 
+
 (** Composition of functions. *)
 
 Notation compose := (fun g f x => g (f x)).
@@ -178,24 +217,10 @@ Notation "g 'o' f" := (compose g%function f%function) : function_scope.
 (** This definition helps guide typeclass inference. *)
 Definition Compose {A B C : Type} (g : B -> C) (f : A -> B) : A -> C := compose g f.
 
-(** Composition of logical equivalences *)
-Global Instance iff_compose : Transitive iff | 1
-  := fun A B C f g => (fst g o fst f , snd f o snd g).
-Arguments iff_compose {A B C} f g : rename.
-
-(** While we're at it, inverses of logical equivalences *)
-Global Instance iff_inverse : Symmetric iff | 1
-  := fun A B f => (snd f , fst f).
-Arguments iff_inverse {A B} f : rename.
-
-(** And reflexivity of them *)
-Global Instance iff_reflexive : Reflexive iff | 1
-  := fun A => (idmap , idmap).
-
 (** Dependent composition of functions. *)
 Definition composeD {A B C} (g : forall b, C b) (f : A -> B) := fun x : A => g (f x).
 
-Global Arguments composeD {A B C}%type_scope (g f)%function_scope x.
+Global Arguments composeD {A B C}%_type_scope (g f)%_function_scope x.
 
 #[export] Hint Unfold composeD : core.
 
@@ -325,7 +350,7 @@ Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x)
   := match p with idpath => u end.
 
 (** See above for the meaning of [simpl nomatch]. *)
-Arguments transport {A}%type_scope P%function_scope {x y} p%path_scope u : simpl nomatch.
+Arguments transport {A}%_type_scope P%_function_scope {x y} p%_path_scope u : simpl nomatch.
 
 (** Transport is very common so it is worth introducing a parsing notation for it.  However, we do not use the notation for output because it hides the fibration, and so makes it very hard to read involved transport expression. *)
 Notation "p # x" := (transport _ p x) (only parsing) : path_scope.
@@ -338,8 +363,8 @@ Proof. rewrite <- H. exact u. Defined.
 Local Lemma define_internal_paths_rew_r A x y P (u : P y) (H : x = y :> A) : P x.
 Proof. rewrite -> H. exact u. Defined.
 
-Arguments internal_paths_rew {A%type_scope} {a} P%function_scope f {a0} p.
-Arguments internal_paths_rew_r {A%type_scope} {a y} P%function_scope HC X.
+Arguments internal_paths_rew {A%_type_scope} {a} P%_function_scope f {a0} p.
+Arguments internal_paths_rew_r {A%_type_scope} {a y} P%_function_scope HC X.
 
 (** Having defined transport, we can use it to talk about what a homotopy theorist might see as "paths in a fibration over paths in the base"; and what a type theorist might see as "heterogeneous equality in a dependent type".  We will first see this appearing in the type of [apD]. *)
 
@@ -348,7 +373,7 @@ Arguments internal_paths_rew_r {A%type_scope} {a y} P%function_scope HC X.
 Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
   := match p with idpath => idpath end.
 
-Global Arguments ap {A B}%type_scope f%function_scope {x y} p%path_scope.
+Global Arguments ap {A B}%_type_scope f%_function_scope {x y} p%_path_scope.
 
 Register ap as core.identity.congr.
 
@@ -382,7 +407,7 @@ Proof.
   intros ? ? p ?; symmetry; apply p.
 Defined.
 
-Global Arguments pointwise_paths {A}%type_scope {P} (f g)%function_scope.
+Global Arguments pointwise_paths {A}%_type_scope {P} (f g)%_function_scope.
 Global Arguments reflexive_pointwise_paths /.
 Global Arguments transitive_pointwise_paths /.
 Global Arguments symmetric_pointwise_paths /.
@@ -396,12 +421,12 @@ Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g)
   : f == g
   := fun x => match h with idpath => 1 end.
 
-Global Arguments apD10 {A%type_scope B} {f g}%function_scope h%path_scope _.
+Global Arguments apD10 {A%_type_scope B} {f g}%_function_scope h%_path_scope _.
 
 Definition ap10 {A B} {f g:A->B} (h:f=g) : f == g
   := apD10 h.
 
-Global Arguments ap10 {A B}%type_scope {f g}%function_scope h%path_scope _.
+Global Arguments ap10 {A B}%_type_scope {f g}%_function_scope h%_path_scope _.
 
 (** For the benefit of readers of the HoTT Book: *)
 Notation happly := ap10 (only parsing).
@@ -411,7 +436,7 @@ Proof.
   case h, p; reflexivity.
 Defined.
 
-Global Arguments ap11 {A B}%type_scope {f g}%function_scope h%path_scope {x y} p%path_scope.
+Global Arguments ap11 {A B}%_type_scope {f g}%_function_scope h%_path_scope {x y} p%_path_scope.
 
 (** See above for the meaning of [simpl nomatch]. *)
 Arguments ap {A B} f {x y} p : simpl nomatch.
@@ -426,7 +451,7 @@ Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y):
   match p with idpath => idpath end.
 
 (** See above for the meaning of [simpl nomatch]. *)
-Arguments apD {A%type_scope B} f%function_scope {x y} p%path_scope : simpl nomatch.
+Arguments apD {A%_type_scope B} f%_function_scope {x y} p%_path_scope : simpl nomatch.
 
 (** ** Equivalences *)
 
@@ -452,10 +477,10 @@ Class IsEquiv {A B : Type} (f : A -> B) := {
   eisadj : forall x : A, eisretr (f x) = ap f (eissect x) ;
 }.
 
-Arguments eisretr {A B}%type_scope f%function_scope {_} _.
-Arguments eissect {A B}%type_scope f%function_scope {_} _.
-Arguments eisadj {A B}%type_scope f%function_scope {_} _.
-Arguments IsEquiv {A B}%type_scope f%function_scope.
+Arguments eisretr {A B}%_type_scope f%_function_scope {_} _.
+Arguments eissect {A B}%_type_scope f%_function_scope {_} _.
+Arguments eisadj {A B}%_type_scope f%_function_scope {_} _.
+Arguments IsEquiv {A B}%_type_scope f%_function_scope.
 
 (** We mark [eisadj] as Opaque to deter Coq from unfolding it when simplifying. Since proofs of [eisadj] typically have larger proofs than the rest of the equivalence data, we gain some speed up as a result. *)
 Global Opaque eisadj.
@@ -522,7 +547,7 @@ Definition trunc_index_rect := trunc_index_ind.
 
 (** We will use [Notation] for [trunc_index]es, so define a scope for them here. *)
 Bind Scope trunc_scope with trunc_index.
-Arguments trunc_S _%trunc_scope.
+Arguments trunc_S _%_trunc_scope.
 
 (** Include the basic numerals, so we don't need to go through the coercion from [nat], and so that we get the right binding with [trunc_scope]. *)
 (** Note that putting the negative numbers at level 0 allows us to override the [- _] notation for negative numbers. *)
@@ -635,7 +660,7 @@ Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A,
   :=
   (@apD10 A P f g)^-1.
 
-Global Arguments path_forall {_ A%type_scope P} (f g)%function_scope _.
+Global Arguments path_forall {_ A%_type_scope P} (f g)%_function_scope _.
 
 (** *** Tactics *)
 
@@ -654,16 +679,14 @@ Ltac path_via mid :=
 
 (** ** Natural numbers *)
 
-(** Unfortunately due to a bug in coq #10766 the induction tactic fails to work properly. We therefore have to use the autogenerated induction schemes and define the ones we want to use ourselves. *)
-
-Local Set Elimination Schemes.
-
 (**  Natural numbers. *)
 Inductive nat : Type0 :=
 | O : nat
 | S : nat -> nat.
 
-Local Unset Elimination Schemes.
+Scheme nat_ind := Induction for nat Sort Type.
+Scheme nat_rect := Induction for nat Sort Type.
+Scheme nat_rec := Induction for nat Sort Type.
 
 (** These schemes are therefore defined in Spaces.Nat *)
 (*
@@ -675,7 +698,7 @@ Scheme nat_rec := Minimality for nat Sort Type.
 Declare Scope nat_scope.
 Delimit Scope nat_scope with nat.
 Bind Scope nat_scope with nat.
-Arguments S _%nat.
+Arguments S _%_nat.
 
 (** We put [Empty] here, instead of in [Empty.v], because [Ltac done] uses it. *)
 Inductive Empty : Type0 := .
@@ -746,27 +769,4 @@ Global Existing Instance ispointed_type.
 
 Definition hfiber {A B : Type} (f : A -> B) (y : B) := { x : A & f x = y }.
 
-Global Arguments hfiber {A B}%type_scope f%function_scope y.
-
-(** *** More tactics *)
-
-Ltac easy :=
-  let rec use_hyp H :=
-    match type of H with
-    | _ => try solve [inversion H]
-    end
-  with do_intro := let H := fresh in intro H; use_hyp H
-  with destruct_hyp H := case H; clear H; do_intro; do_intro in
-  let rec use_hyps :=
-    match goal with
-    | H : _ |- _ => solve [inversion H]
-    | _ => idtac
-    end in
-  let rec do_atom :=
-    solve [reflexivity | symmetry; trivial] ||
-    contradiction ||
-    (split; do_atom)
-  with do_ccl := trivial; repeat do_intro; do_atom in
-  (use_hyps; do_ccl) || fail "Cannot solve this goal".
-
-Tactic Notation "now" tactic(t) := t; easy.
+Global Arguments hfiber {A B}%_type_scope f%_function_scope y.
diff --git a/theories/Basics/PathGroupoids.v b/theories/Basics/PathGroupoids.v
index 52c4ebd2a03..f98b18c80dd 100644
--- a/theories/Basics/PathGroupoids.v
+++ b/theories/Basics/PathGroupoids.v
@@ -774,8 +774,49 @@ Definition transportD2 {A : Type} (B C : A -> Type) (D : forall a:A, B a -> C a
 Definition ap011 {A B C} (f : A -> B -> C) {x x' y y'} (p : x = x') (q : y = y')
   : f x y = f x' y'.
 Proof.
-  destruct p, q.
-  reflexivity.
+  destruct p.
+  apply ap.
+  exact q.
+Defined.
+
+Definition ap011_V {A B C} (f : A -> B -> C) {x x' y y'} (p : x = x') (q : y = y')
+  : ap011 f p^ q^ = (ap011 f p q)^.
+Proof.
+  destruct p.
+  apply ap_V.
+Defined.
+
+Definition ap011_pp {A B C} (f : A -> B -> C) {x x' x'' y y' y''}
+  (p : x = x') (p' : x' = x'') (q : y = y') (q' : y' = y'')
+  : ap011 f (p @ p') (q @ q') = ap011 f p q @ ap011 f p' q'.
+Proof.
+  destruct p, p'.
+  apply ap_pp.
+Defined.
+
+Definition ap011_compose {A B C D} (f : A -> B -> C) (g : C -> D) {x x' y y'}
+  (p : x = x') (q : y = y')
+  : ap011 (fun x y => g (f x y)) p q = ap g (ap011 f p q).
+Proof.
+  destruct p; simpl.
+  apply ap_compose.
+Defined.
+
+Definition ap011_compose' {A B C D E} (f : A -> B -> C) (g : D -> A) (h : E -> B)
+  {x x' y y'}
+  (p : x = x') (q : y = y')
+  : ap011 (fun x y => f (g x) (h y)) p q = ap011 f (ap g p) (ap h q).
+Proof.
+  destruct p; simpl.
+  apply ap_compose.
+Defined.
+
+Definition ap011_is_ap {A B C} (f : A -> B -> C) {x x' : A} {y y' : B} (p : x = x') (q : y = y')
+  : ap011 f p q = ap (fun x => f x y) p @ ap (fun y => f x' y) q.
+Proof.
+  destruct p.
+  symmetry.
+  apply concat_1p.
 Defined.
 
 (** It would be nice to have a consistent way to name the different ways in which this can be dependent.  The following are a sort of half-hearted attempt. *)
@@ -1223,6 +1264,33 @@ Proof.
   destruct p, r, q. reflexivity.
 Defined.
 
+(** Naturality of [concat_p_pp] in left-most argument. *)
+Definition concat_p_pp_nat_l {A} {w x y z : A}
+  {p p' : w = x} (h : p = p') (q : x = y) (r : y = z)
+  : whiskerR h (q @ r) @ concat_p_pp p' q r
+    = concat_p_pp p q r @ whiskerR (whiskerR h q) r.
+Proof.
+  by destruct h, p, q, r.
+Defined.
+
+(** Naturality of [concat_p_pp] in middle argument. *)
+Definition concat_p_pp_nat_m {A} {w x y z : A}
+  (p : w = x) {q q' : x = y} (h : q = q') (r : y = z)
+  : whiskerL p (whiskerR h r) @ concat_p_pp p q' r
+    = concat_p_pp p q r @ whiskerR (whiskerL p h) r.
+Proof.
+  by destruct h, p, q, r.
+Defined.
+
+(** Naturality of [concat_p_pp] in right-most argument. *)
+Definition concat_p_pp_nat_r {A} {w x y z : A}
+  (p : w = x) (q : x = y) {r r' : y = z} (h : r = r')
+  : whiskerL p (whiskerL q h) @ concat_p_pp p q r'
+    = concat_p_pp p q r @ whiskerL (p @ q) h.
+Proof.
+  by destruct h, p, q, r.
+Defined.
+
 (** The interchange law for concatenation. *)
 Definition concat_concat2 {A : Type} {x y z : A} {p p' p'' : x = y} {q q' q'' : y = z}
   (a : p = p') (b : p' = p'') (c : q = q') (d : q' = q'') :
@@ -1319,6 +1387,15 @@ Proof.
   destruct r1, r2. destruct p1. reflexivity.
 Defined.
 
+Definition ap022 {A B C} (f : A -> B -> C) {x x' y y'}
+  {p p' : x = x'} (r : p = p') {q q' : y = y'} (s : q = q')
+  : ap011 f p q = ap011 f p' q'.
+Proof.
+  destruct r, p.
+  apply ap02.
+  exact s.
+Defined.
+
 (** These lemmas need better names. *)
 Definition ap_transport_Vp_idmap {A B} (p q : A = B) (r : q = p) (z : A)
 : ap (transport idmap q^) (ap (fun s => transport idmap s z) r)
diff --git a/theories/Basics/Settings.v b/theories/Basics/Settings.v
new file mode 100644
index 00000000000..cb5d6d46745
--- /dev/null
+++ b/theories/Basics/Settings.v
@@ -0,0 +1,77 @@
+(** * General Settings *)
+
+(** This file contains all the tweaks and settings we make to Coq. *)
+
+(** ** Warnings *)
+
+(** ** Plugins *)
+
+(** Load the Ltac plugin. This is the tactic language we use for proofs. *)
+Declare ML Module "ltac_plugin".
+(** Load the number string notation plugin. Allowing us to write numbers like [1234]. *)
+Declare ML Module "number_string_notation_plugin".
+
+(** ** Proofs *)
+
+(** Activate the Ltac tactics language for proofs. *)
+Global Set Default Proof Mode "Classic".
+
+(** Force use of bullets in proofs. *)
+Global Set Default Goal Selector "!".
+
+(** ** Universes *)
+
+(** Activate universe polymorphism everywhere. This means that whenever you see a [Type], it's actually a [Type@{i}] for some universe level [i]. This allows us to reuse definitions for each universe level without having to redefine them. *)
+Global Set Universe Polymorphism.
+
+(** This command makes it so that you don't have to declare universes explicitly when mentioning them in the type.  (Without this command, if you want to say [Definition foo := Type@{i}.], you must instead say [Definition foo@{i} := Type@{i}.]. *)
+Global Unset Strict Universe Declaration.
+
+(** This command makes it so that when we say something like [IsHSet nat] we get [IsHSet@{i} nat] instead of [IsHSet@{Set} nat]. *)
+Global Unset Universe Minimization ToSet.
+
+(** ** Primitive Projections *)
+
+Global Set Primitive Projections.
+Global Set Nonrecursive Elimination Schemes.
+
+(** Currently Coq doesn't print equivalences correctly (8.6). This fixes that. See https://github.com/HoTT/HoTT/issues/1000 *)
+Global Set Printing Primitive Projection Parameters.
+
+(** ** Pattern Matching *)
+
+(** This flag revoves parameters from constructors in patterns that appear in a match statement. *)
+Global Set Asymmetric Patterns.
+
+(** ** Unification *)
+
+(** This command changes Coq's subterm selection to always use full conversion after finding a subterm whose head/key matches the key of the term we're looking for.  This applies to [rewrite] and higher-order unification in [apply]/[elim]/[destruct].  Again, if you don't know what that means, ignore it. *)
+Global Set Keyed Unification.
+
+(** ** Typeclasses and Hint settings *)
+
+(** This tells Coq that when we [Require] a module without [Import]ing it, typeclass instances defined in that module should also not be imported.  In other words, the only effect of [Require] without [Import] is to make qualified names available. *)
+Global Set Loose Hint Behavior "Strict".
+
+Create HintDb rewrite discriminated.
+#[export] Hint Variables Opaque : rewrite.
+Create HintDb typeclass_instances discriminated.
+
+(** ** Reversible Coercions *)
+
+(** Coercions in Coq since 8.16 have the ability to be reversible. These are coercions that are not regular functions but rely on some meta-procedure like typeclass resolution to fill in missing pieces. Examples include marking fields of a record with [:>] which allows Coq to elaborate the projected term to the original term.
+
+This behaviour can have some surprising effects in some places, where you might not expect a term to be elaborated. When inspecting proofs with [Set Printing All] you will not be able to see the reverisble coercion. In order to help with inspecting such situations, Coq exposes a register for a dummy term called [reverse_coercion] which gets inserted during an application of a reversible coercion. This way you can see the application clearly in a proof term.
+
+We register this here. This is standard from the Coq stdlib prelude.*)
+#[universes(polymorphic=yes)] Definition ReverseCoercionSource (T : Type) := T.
+#[universes(polymorphic=yes)] Definition ReverseCoercionTarget (T : Type) := T.
+#[warning="-uniform-inheritance", reversible=no, universes(polymorphic=yes)]
+Coercion reverse_coercion {T' T} (x' : T') (x : ReverseCoercionSource T)
+  : ReverseCoercionTarget T' := x'.
+Register reverse_coercion as core.coercion.reverse_coercion.
+
+(** ** Search Settings *)
+
+(** Keywords for blacklisting from search function *)
+Add Search Blacklist "_admitted" "_subproof" "Private_".
diff --git a/theories/Basics/Tactics.v b/theories/Basics/Tactics.v
index 45d8fe60eda..9cc6200b67a 100644
--- a/theories/Basics/Tactics.v
+++ b/theories/Basics/Tactics.v
@@ -239,7 +239,7 @@ Ltac bang :=
   match goal with
     | |- ?x =>
       match x with
-        | context [False_rect _ ?p] => elim p
+        | context [Empty_rect _ ?p] => elim p
       end
   end.
 
@@ -459,6 +459,30 @@ Ltac done :=
 Tactic Notation "by" tactic(tac) :=
   tac; done.
 
+Ltac easy :=
+  let rec use_hyp H :=
+    match type of H with
+    | _ => try solve [inversion H]
+    end
+  with do_intro := let H := fresh in intro H; use_hyp H
+  with destruct_hyp H := case H; clear H; do_intro; do_intro in
+  let rec use_hyps :=
+    match goal with
+    | H : _ |- _ => solve [inversion H]
+    | _ => idtac
+    end in
+  let rec do_atom :=
+    solve [reflexivity | symmetry; trivial] ||
+    contradiction ||
+    (split; do_atom)
+  with do_ccl := trivial; repeat do_intro; do_atom in
+  (use_hyps; do_ccl) || fail "Cannot solve this goal".
+
+Tactic Notation "now" tactic(t) := t; easy.
+
+(** Apply using the same opacity information as typeclass proof search. *)
+Ltac class_apply c := autoapply c with typeclass_instances.
+
 (** A convenient tactic for using function extensionality. *)
 Ltac by_extensionality x :=
   intros;
@@ -472,7 +496,6 @@ Ltac by_extensionality x :=
     simpl; auto with path_hints
   end.
 
-
 (** [funext] apply functional extensionality ([path_forall]) to the goal and the introduce the arguments in the context. *)
 (** For instance, if you have to prove [f = g] where [f] and [g] take two arguments, you can use [funext x y], and the goal become [f x y = g x y]. *)
 Tactic Notation "funext" simple_intropattern(a)
@@ -561,7 +584,7 @@ Ltac get_constructor_head T :=
                              let x' := (eval cbv delta [x'] in x') in
                              let x' := head x' in
                              unify h x';
-                             exact I)) in
+                             exact tt)) in
   h.
 
 (* A version of econstructor that doesn't resolve typeclasses. *)
@@ -697,7 +720,7 @@ Local Ltac unify_with_projections term u :=
   (unify_first_evar_with term u;
    tryif has_evar term then fail 0 term "has evars remaining" else idtac).
 
-(* Completely destroys v into it's pieces and trys to put pieces in sigma. *)
+(* Completely destroys v into its pieces and trys to put pieces in sigma. *)
 Local Ltac refine_with_exist_as_much_as_needed_then_destruct v :=
   ((destruct v; shelve) +
    (snrefine (_ ; _);
diff --git a/theories/Basics/Trunc.v b/theories/Basics/Trunc.v
index 48f1758184c..508f323391b 100644
--- a/theories/Basics/Trunc.v
+++ b/theories/Basics/Trunc.v
@@ -7,7 +7,8 @@ Require Import
   Basics.Contractible
   Basics.Equivalences
   Basics.Tactics
-  Basics.Nat.
+  Basics.Nat
+  Basics.Iff.
 
 Local Set Universe Minimization ToSet.
 
diff --git a/theories/Basics/Utf8.v b/theories/Basics/Utf8.v
index f2f6e7c439e..f5180f5b56f 100644
--- a/theories/Basics/Utf8.v
+++ b/theories/Basics/Utf8.v
@@ -19,19 +19,18 @@ Reserved Infix "∘ˡ" (at level 40, left associativity).
 Reserved Infix "∘ʳ" (at level 40, left associativity).
 Reserved Infix "⊣" (at level 60, right associativity).
 Reserved Infix "≅" (at level 70, no associativity).
-Reserved Notation "A 'ᵒᵖ'" (at level 3).
+Reserved Notation "A 'ᵒᵖ'" (at level 1).
 Reserved Notation "A × B" (at level 40, left associativity).
 Reserved Notation "a ≤ b" (at level 70, no associativity).
 Reserved Notation "A ≃ B" (at level 85).
-Reserved Notation "a ⇓ 'CAT'" (at level 40, left associativity).
-Reserved Notation "a ⇑ 'CAT'" (at level 40, left associativity).
+Reserved Notation "a ⇓ 'CAT'" (at level 1, left associativity).
+Reserved Notation "a ⇑ 'CAT'" (at level 1, left associativity).
 Reserved Notation "a ≤_{ x } b" (at level 70, no associativity).
 Reserved Notation "C ↓ a" (at level 70, no associativity).
 Reserved Notation "'CAT' ⇓ a" (at level 40, left associativity).
 Reserved Notation "'CAT' ⇑ a" (at level 40, left associativity).
-Reserved Notation "C 'ᵒᵖ'" (at level 3).
 Reserved Notation "C → D" (at level 99, D at level 200, right associativity).
-Reserved Notation "f '⁻¹'" (at level 3, format "f '⁻¹'").
+Reserved Notation "f '⁻¹'" (at level 1, format "f '⁻¹'").
 (* Reserved Notation "f ×ᴱ g" (at level 40, no associativity). *)
 (* Reserved Notation "f *ᴱ g" (at level 40, no associativity). *)
 Reserved Notation "f +ᴱ g" (at level 50, left associativity).
@@ -39,13 +38,11 @@ Reserved Notation "F ₁ m" (at level 10, no associativity).
 Reserved Notation "F ₀ x" (at level 10, no associativity).
 Reserved Notation "g ∘ f" (at level 40, left associativity).
 Reserved Notation "g ∘ᴱ f" (at level 40, left associativity).
-Reserved Notation "m ⁻¹" (at level 3, format "m '⁻¹'").
 Reserved Notation "m ≤ n" (at level 70, no associativity).
-Reserved Notation "p '⁻¹'" (at level 3, format "p '⁻¹'").
 Reserved Notation "p • q" (at level 20).
 Reserved Notation "p •' q" (at level 21, left associativity, format "'[v' p '/' '•''  q ']'").
-Reserved Notation "x ₁" (at level 3).
-Reserved Notation "x ₂" (at level 3).
+Reserved Notation "x ₁" (at level 1).
+Reserved Notation "x ₂" (at level 1).
 Reserved Notation "¬ x" (at level 35, right associativity).
 Reserved Notation "x ⇓ F" (at level 40, left associativity).
 Reserved Notation "x ⇑ F" (at level 40, left associativity).
diff --git a/theories/BoundedSearch.v b/theories/BoundedSearch.v
index 234b13955c6..01e30fb5335 100644
--- a/theories/BoundedSearch.v
+++ b/theories/BoundedSearch.v
@@ -57,14 +57,14 @@ Section bounded_search.
         * left.
           refine (n.+1;(h,_,_)).
           -- intros m pm.
-             assert ((n.+1 <= m)+(n.+1>m)) as X by apply leq_dichot.
+             assert ((n.+1 <= m)+(n.+1>m)) as X by apply leq_dichotomy.
              destruct X as [leqSnm|ltmSn].
              ++ assumption.
              ++ unfold gt, lt in ltmSn.
-                assert (m <= n) as X by rapply leq_S_n.
+                assert (m <= n) as X by rapply leq_pred'.
                 destruct (n0 m X pm).
         * right. intros l q.
-          assert ((l <= n) + (l > n)) as X by apply leq_dichot.
+          assert ((l <= n) + (l > n)) as X by apply leq_dichotomy.
           destruct X as [h|h].
           -- exact (n0 l h).
           -- unfold lt in h.
diff --git a/theories/Categories/Adjoint/Hom.v b/theories/Categories/Adjoint/Hom.v
index c8d94995f24..1e04a627a9d 100644
--- a/theories/Categories/Adjoint/Hom.v
+++ b/theories/Categories/Adjoint/Hom.v
@@ -84,4 +84,4 @@ End Adjunction.
 Coercion mate_of : AdjunctionHom >-> NaturalIsomorphism.
 Bind Scope adjunction_scope with AdjunctionHom.
 
-Arguments mate_of {_} [C%category D%category F%functor G%functor] _%adjunction.
+Arguments mate_of {_} [C%_category D%_category F%_functor G%_functor] _%_adjunction.
diff --git a/theories/Categories/Adjoint/UnitCounit.v b/theories/Categories/Adjoint/UnitCounit.v
index a5b7bc2ecc3..0212926a386 100644
--- a/theories/Categories/Adjoint/UnitCounit.v
+++ b/theories/Categories/Adjoint/UnitCounit.v
@@ -283,8 +283,8 @@ Bind Scope adjunction_scope with AdjunctionUnit.
 Bind Scope adjunction_scope with AdjunctionCounit.
 Bind Scope adjunction_scope with AdjunctionUnitCounit.
 
-Arguments unit [C D]%category [F G]%functor _%adjunction / .
-Arguments counit [C D]%category [F G]%functor _%adjunction / .
-Arguments AdjunctionUnitCounit [C D]%category (F G)%functor.
-Arguments unit_counit_equation_1 [C D]%category [F G]%functor _%adjunction _%object.
-Arguments unit_counit_equation_2 [C D]%category [F G]%functor _%adjunction _%object.
+Arguments unit [C D]%_category [F G]%_functor _%_adjunction / .
+Arguments counit [C D]%_category [F G]%_functor _%_adjunction / .
+Arguments AdjunctionUnitCounit [C D]%_category (F G)%_functor.
+Arguments unit_counit_equation_1 [C D]%_category [F G]%_functor _%_adjunction _%_object.
+Arguments unit_counit_equation_2 [C D]%_category [F G]%_functor _%_adjunction _%_object.
diff --git a/theories/Categories/Category/Core.v b/theories/Categories/Category/Core.v
index 56766135f00..08a05c04888 100644
--- a/theories/Categories/Category/Core.v
+++ b/theories/Categories/Category/Core.v
@@ -79,10 +79,10 @@ Bind Scope object_scope with object.
 Bind Scope morphism_scope with morphism.
 
 (** We want eta-expanded primitive projections to [simpl] away. *)
-Arguments object !C%category / : rename.
-Arguments morphism !C%category / s d : rename.
-Arguments identity {!C%category} / x%object : rename.
-Arguments compose {!C%category} / {s d d'}%object (m1 m2)%morphism : rename.
+Arguments object !C%_category / : rename.
+Arguments morphism !C%_category / s d : rename.
+Arguments identity {!C%_category} / x%_object : rename.
+Arguments compose {!C%_category} / {s d d'}%_object (m1 m2)%_morphism : rename.
 
 Local Infix "o" := compose : morphism_scope.
 (** Perhaps we should consider making this notation more global. *)
diff --git a/theories/Categories/Category/Pi.v b/theories/Categories/Category/Pi.v
index a9afc27ebc9..5a9ad06b423 100644
--- a/theories/Categories/Category/Pi.v
+++ b/theories/Categories/Category/Pi.v
@@ -1,7 +1,6 @@
 (** * Dependent Product Category *)
 Require Import Category.Strict.
 Require Import Basics.Trunc.
-Require Import Types.Forall.
 
 Set Universe Polymorphism.
 Set Implicit Arguments.
diff --git a/theories/Categories/Category/Prod.v b/theories/Categories/Category/Prod.v
index cc26ff69f9f..b1a31b81051 100644
--- a/theories/Categories/Category/Prod.v
+++ b/theories/Categories/Category/Prod.v
@@ -17,9 +17,9 @@ Section prod.
 
   Definition prod : PreCategory.
     refine (@Build_PreCategory
-              (C * D)%type
-              (fun s d => (morphism C (fst s) (fst d)
-                           * morphism D (snd s) (snd d))%type)
+              (C * D)
+              (fun s d => morphism C (fst s) (fst d)
+                          * morphism D (snd s) (snd d))
               (fun x => (identity (fst x), identity (snd x)))
               (fun s d d' m2 m1 => (fst m2 o fst m1, snd m2 o snd m1))
               _
diff --git a/theories/Categories/Category/Sigma/Univalent.v b/theories/Categories/Category/Sigma/Univalent.v
index bed82289eb2..eb86e42e55c 100644
--- a/theories/Categories/Category/Sigma/Univalent.v
+++ b/theories/Categories/Category/Sigma/Univalent.v
@@ -50,7 +50,7 @@ Section onmorphisms.
   Variable A : PreCategory.
   Variable Pmor : forall s d, morphism A s d -> Type.
 
-  Local Notation mor s d := { m : _ | Pmor s d m }%type.
+  Local Notation mor s d := { m : _ | Pmor s d m }.
   Context `(HPmor : forall s d, IsHSet (mor s d)).
 
   Variable Pidentity : forall x, @Pmor x x (@identity A _).
@@ -148,11 +148,11 @@ Section on_both.
   Variable A : PreCategory.
   Variable Pobj : A -> Type.
 
-  Local Notation obj := { x : _ | Pobj x }%type (only parsing).
+  Local Notation obj := { x : _ | Pobj x } (only parsing).
 
   Variable Pmor : forall s d : obj, morphism A s.1 d.1 -> Type.
 
-  Local Notation mor s d := { m : _ | Pmor s d m }%type (only parsing).
+  Local Notation mor s d := { m : _ | Pmor s d m } (only parsing).
   Context `(HPmor : forall s d, IsHSet (mor s d)).
 
   Variable Pidentity : forall x, @Pmor x x (@identity A _).
@@ -283,7 +283,7 @@ Section on_both.
 
   Local Definition equiv_iso_A'_eisretr_helper {s d}
         (x : {e : @Isomorphic A s.1 d.1
-             | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse }%type)
+             | Pmor_iso_T s d e e^-1 (@left_inverse _ _ _ e e) right_inverse })
   : transport
       (fun e : @Isomorphic A s.1 d.1 =>
          Pmor_iso_T s d e e^-1 left_inverse right_inverse)
diff --git a/theories/Categories/Category/Sum.v b/theories/Categories/Category/Sum.v
index 6608f7f4a63..89cab02edf5 100644
--- a/theories/Categories/Category/Sum.v
+++ b/theories/Categories/Category/Sum.v
@@ -43,7 +43,7 @@ End internals.
 Definition sum (C D : PreCategory) : PreCategory.
 Proof.
   refine (@Build_PreCategory
-            (C + D)%type
+            (C + D)
             (sum_morphism C D)
             (sum_identity C D)
             (sum_compose C D)
diff --git a/theories/Categories/Comma.v b/theories/Categories/Comma.v
index 95276cb1d0a..f6fe0807146 100644
--- a/theories/Categories/Comma.v
+++ b/theories/Categories/Comma.v
@@ -1,6 +1,7 @@
 (** * Comma Categories *)
 (** Since there are only notations in [Comma.Notations], we can just export those. *)
 Local Set Warnings Append "-notation-overridden".
+Require Import Basics.Notations.
 Require Export Comma.Notations.
 
 (** ** Definitions *)
diff --git a/theories/Categories/Comma/Core.v b/theories/Categories/Comma/Core.v
index 57e89cbeb6d..c5b93a5675d 100644
--- a/theories/Categories/Comma/Core.v
+++ b/theories/Categories/Comma/Core.v
@@ -1,9 +1,9 @@
 (** * Comma categories *)
+Require Import HoTT.Basics HoTT.Types.
 Require Import Functor.Core.
 Require Import InitialTerminalCategory.Core InitialTerminalCategory.Functors.
 Require Functor.Identity.
 Require Import Category.Strict.
-Require Import HoTT.Basics HoTT.Types.
 Import Functor.Identity.FunctorIdentityNotations.
 
 Set Universe Polymorphism.
diff --git a/theories/Categories/Comma/Notations.v b/theories/Categories/Comma/Notations.v
index 14af5a08594..830f2c14bfb 100644
--- a/theories/Categories/Comma/Notations.v
+++ b/theories/Categories/Comma/Notations.v
@@ -1,4 +1,5 @@
 (** * Notations for comma categories *)
+Require Import Basics.Notations.
 Require Comma.Core.
 
 Local Set Warnings Append "-notation-overridden". (* work around bug #5567, https://coq.inria.fr/bugs/show_bug.cgi?id=5567, notation-overridden,parsing should not trigger for only printing notations *)
diff --git a/theories/Categories/Comma/ProjectionFunctors.v b/theories/Categories/Comma/ProjectionFunctors.v
index 0e698e1440c..7e58b84b580 100644
--- a/theories/Categories/Comma/ProjectionFunctors.v
+++ b/theories/Categories/Comma/ProjectionFunctors.v
@@ -46,8 +46,8 @@ Section comma.
              (ST : object ((A -> C)^op * (B -> C)))
   : Cat / !((A * B; PAB) : Cat).
   Proof.
-    exists (Datatypes.fst ST / Datatypes.snd ST; P_comma _ _) (center _).
-    exact (comma_category_projection (Datatypes.fst ST) (Datatypes.snd ST)).
+    exists (Basics.Overture.fst ST / Basics.Overture.snd ST; P_comma _ _) (center _).
+    exact (comma_category_projection (Basics.Overture.fst ST) (Basics.Overture.snd ST)).
   Defined.
 
   Definition comma_category_projection_functor_morphism_of
@@ -64,7 +64,7 @@ Section comma.
               (center _)
               _).
     simpl.
-    destruct_head_hnf Datatypes.prod.
+    destruct_head_hnf Basics.Overture.prod.
     path_functor.
   Defined.
 
@@ -74,7 +74,7 @@ Section comma.
     rewrite !transport_forall_constant;
     transport_path_forall_hammer;
     simpl;
-    destruct_head Datatypes.prod;
+    destruct_head Basics.Overture.prod;
     simpl in *;
     apply CommaCategory.path_morphism;
     simpl;
diff --git a/theories/Categories/Comma/Utf8.v b/theories/Categories/Comma/Utf8.v
index d62a2ed6a21..ad858cc1d53 100644
--- a/theories/Categories/Comma/Utf8.v
+++ b/theories/Categories/Comma/Utf8.v
@@ -1,5 +1,6 @@
 (** * Unicode notations for comma categories *)
 Local Set Warnings Append "-notation-overridden".
+Require Import Basics.Notations.
 Require Import Comma.Core.
 Require Export Comma.Notations.
 Require Import Basics.Utf8.
diff --git a/theories/Categories/ExponentialLaws/Law2/Functors.v b/theories/Categories/ExponentialLaws/Law2/Functors.v
index 2cf6057be1c..30da3e5507b 100644
--- a/theories/Categories/ExponentialLaws/Law2/Functors.v
+++ b/theories/Categories/ExponentialLaws/Law2/Functors.v
@@ -8,9 +8,9 @@ Set Asymmetric Patterns.
 
 Local Open Scope functor_scope.
 
-Local Notation fst_type := Basics.Datatypes.fst.
-Local Notation snd_type := Basics.Datatypes.snd.
-Local Notation pair_type := Basics.Datatypes.pair.
+Local Notation fst_type := Basics.Overture.fst.
+Local Notation snd_type := Basics.Overture.snd.
+Local Notation pair_type := Basics.Overture.pair.
 
 Section law2.
   Context `{Funext}.
diff --git a/theories/Categories/ExponentialLaws/Law2/Law.v b/theories/Categories/ExponentialLaws/Law2/Law.v
index 632bab009e0..b3fe87c6053 100644
--- a/theories/Categories/ExponentialLaws/Law2/Law.v
+++ b/theories/Categories/ExponentialLaws/Law2/Law.v
@@ -21,8 +21,8 @@ Section Law2.
 
 
   Lemma helper1 (c : Functor C1 D * Functor C2 D)
-  : ((1 o (Datatypes.fst c + Datatypes.snd c) o inl C1 C2)%functor,
-     (1 o (Datatypes.fst c + Datatypes.snd c) o inr C1 C2)%functor)%core = c.
+  : ((1 o (Basics.Overture.fst c + Basics.Overture.snd c) o inl C1 C2)%functor,
+     (1 o (Basics.Overture.fst c + Basics.Overture.snd c) o inr C1 C2)%functor)%core = c.
   Proof.
     apply path_prod; simpl;
     path_functor.
diff --git a/theories/Categories/ExponentialLaws/Law3/Functors.v b/theories/Categories/ExponentialLaws/Law3/Functors.v
index cf3723f2318..881ca23312e 100644
--- a/theories/Categories/ExponentialLaws/Law3/Functors.v
+++ b/theories/Categories/ExponentialLaws/Law3/Functors.v
@@ -11,9 +11,9 @@ Set Asymmetric Patterns.
 Local Open Scope natural_transformation_scope.
 Local Open Scope functor_scope.
 
-Local Notation fst_type := Basics.Datatypes.fst.
-Local Notation snd_type := Basics.Datatypes.snd.
-Local Notation pair_type := Basics.Datatypes.pair.
+Local Notation fst_type := Basics.Overture.fst.
+Local Notation snd_type := Basics.Overture.snd.
+Local Notation pair_type := Basics.Overture.pair.
 
 Section law3.
   Context `{Funext}.
diff --git a/theories/Categories/ExponentialLaws/Law3/Law.v b/theories/Categories/ExponentialLaws/Law3/Law.v
index 0821adcf902..644a4b65c64 100644
--- a/theories/Categories/ExponentialLaws/Law3/Law.v
+++ b/theories/Categories/ExponentialLaws/Law3/Law.v
@@ -19,8 +19,8 @@ Section Law3.
   Variables C1 C2 D : PreCategory.
 
   Lemma helper (c : Functor D C1 * Functor D C2)
-  : ((fst o (Datatypes.fst c * Datatypes.snd c))%functor,
-     (snd o (Datatypes.fst c * Datatypes.snd c))%functor)%core = c.
+  : ((fst o (Basics.Overture.fst c * Basics.Overture.snd c))%functor,
+     (snd o (Basics.Overture.fst c * Basics.Overture.snd c))%functor)%core = c.
   Proof.
     apply path_prod;
     [ apply compose_fst_prod
diff --git a/theories/Categories/ExponentialLaws/Tactics.v b/theories/Categories/ExponentialLaws/Tactics.v
index d280489b41c..e78835c799b 100644
--- a/theories/Categories/ExponentialLaws/Tactics.v
+++ b/theories/Categories/ExponentialLaws/Tactics.v
@@ -21,10 +21,10 @@ Ltac exp_laws_misc_t' :=
 Ltac exp_laws_simplify_types' :=
   idtac;
   match goal with
-    | [ H : (_ + _)%type |- _ ] => destruct H
+    | [ H : (_ + _) |- _ ] => destruct H
     | [ H : Unit |- _ ] => destruct H
     | [ H : Empty |- _ ] => destruct H
-    | [ H : (_ * _)%type |- _ ] => destruct H
+    | [ H : (_ * _) |- _ ] => destruct H
     | [ |- _ = _ :> Functor _ _ ] => progress path_functor
     | [ |- _ = _ :> NaturalTransformation _ _ ] => progress path_natural_transformation
     | [ |- _ = _ :> prod _ _ ] => apply path_prod
diff --git a/theories/Categories/Functor/Core.v b/theories/Categories/Functor/Core.v
index afbe31582e6..6073f75d28a 100644
--- a/theories/Categories/Functor/Core.v
+++ b/theories/Categories/Functor/Core.v
@@ -47,8 +47,8 @@ Bind Scope functor_scope with Functor.
 Create HintDb functor discriminated.
 
 Arguments Functor C D : assert.
-Arguments object_of {C%category D%category} F%functor c%object : rename, simpl nomatch.
-Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch.
+Arguments object_of {C%_category D%_category} F%_functor c%_object : rename, simpl nomatch.
+Arguments morphism_of [C%_category] [D%_category] F%_functor [s%_object d%_object] m%_morphism : rename, simpl nomatch.
 
 Arguments composition_of [C D] F _ _ _ _ _ : rename.
 Arguments identity_of [C D] F _ : rename.
diff --git a/theories/Categories/Functor/Prod/Functorial.v b/theories/Categories/Functor/Prod/Functorial.v
index 0e51de10cce..ad130f971a1 100644
--- a/theories/Categories/Functor/Prod/Functorial.v
+++ b/theories/Categories/Functor/Prod/Functorial.v
@@ -9,9 +9,9 @@ Set Asymmetric Patterns.
 
 Local Open Scope natural_transformation_scope.
 
-Local Notation fst_type := Basics.Datatypes.fst.
-Local Notation snd_type := Basics.Datatypes.snd.
-Local Notation pair_type := Basics.Datatypes.pair.
+Local Notation fst_type := Basics.Overture.fst.
+Local Notation snd_type := Basics.Overture.snd.
+Local Notation pair_type := Basics.Overture.pair.
 
 (** ** Construction of product of functors as a functor - [_×_ : (C → D) × (C → D') → (C → D × D')] *)
 Section functorial.
diff --git a/theories/Categories/Functor/Prod/Universal.v b/theories/Categories/Functor/Prod/Universal.v
index 06c462a023f..ebee3843ba3 100644
--- a/theories/Categories/Functor/Prod/Universal.v
+++ b/theories/Categories/Functor/Prod/Universal.v
@@ -9,10 +9,10 @@ Set Implicit Arguments.
 Generalizable All Variables.
 Set Asymmetric Patterns.
 
-Local Notation fst_type := Basics.Datatypes.fst.
-Local Notation snd_type := Basics.Datatypes.snd.
-Local Notation pair_type := Basics.Datatypes.pair.
-Local Notation prod_type := Basics.Datatypes.prod.
+Local Notation fst_type := Basics.Overture.fst.
+Local Notation snd_type := Basics.Overture.snd.
+Local Notation pair_type := Basics.Overture.pair.
+Local Notation prod_type := Basics.Overture.prod.
 
 Local Open Scope morphism_scope.
 Local Open Scope functor_scope.
diff --git a/theories/Categories/Functor/Sum.v b/theories/Categories/Functor/Sum.v
index fc951597a8d..ab041edf94e 100644
--- a/theories/Categories/Functor/Sum.v
+++ b/theories/Categories/Functor/Sum.v
@@ -89,7 +89,7 @@ Section swap_functor.
     transport_path_forall_hammer.
       by repeat match goal with
                   | [ H : Empty |- _ ] => destruct H
-                  | [ H : (_ + _)%type |- _ ] => destruct H
+                  | [ H : (_ + _) |- _ ] => destruct H
                   | _ => progress hnf in *
                 end.
   Qed.
diff --git a/theories/Categories/GroupoidCategory/Core.v b/theories/Categories/GroupoidCategory/Core.v
index e567b2a9e23..e5f3adc96d1 100644
--- a/theories/Categories/GroupoidCategory/Core.v
+++ b/theories/Categories/GroupoidCategory/Core.v
@@ -1,6 +1,6 @@
 (** * Groupoids *)
 Require Import Category.Morphisms Category.Strict.
-Require Import Trunc Types.Forall PathGroupoids Basics.Tactics.
+Require Import Trunc PathGroupoids Basics.Tactics.
 
 Set Universe Polymorphism.
 Set Implicit Arguments.
diff --git a/theories/Categories/LaxComma/Core.v b/theories/Categories/LaxComma/Core.v
index f4dfd385bcf..96741708207 100644
--- a/theories/Categories/LaxComma/Core.v
+++ b/theories/Categories/LaxComma/Core.v
@@ -175,7 +175,7 @@ Module Export LaxCommaCoreNotations.
   (** We play some games to get nice notations for lax comma categories. *)
   Section tc_notation_boiler_plate.
     Local Open Scope type_scope.
-    Class LCC_Builder {A B C} (x : A) (y : B) (z : C) : Set := lcc_builder_dummy : True.
+    Class LCC_Builder {A B C} (x : A) (y : B) (z : C) : Set := lcc_builder_dummy : Unit.
     Definition get_LCC `{@LCC_Builder A B C x y z} : C := z.
 
     Global Arguments get_LCC / {A B C} x y {z} {_}.
@@ -184,33 +184,33 @@ Module Export LaxCommaCoreNotations.
            (S : Pseudofunctor A) (T : Pseudofunctor B)
            {_ : forall a b, IsHSet (Functor (S a) (T b))}
     : LCC_Builder S T (lax_comma_category S T) | 1000
-      := I.
+      := tt.
 
     Global Instance LCC_slice `{Funext} A x (F : Pseudofunctor A)
            `{forall a0, IsHSet (Functor (F a0) x)}
     : LCC_Builder F x (lax_slice_category x F) | 100
-      := I.
+      := tt.
 
     Global Instance LCC_coslice `{Funext} A x (F : Pseudofunctor A)
            `{forall a0, IsHSet (Functor x (F a0))}
     : LCC_Builder x F (lax_coslice_category x F) | 100
-      := I.
+      := tt.
 
     Global Instance LCC_slice_over `{Funext}
            P `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}
            a
            `{forall a0 : @sub_pre_cat _ P HF, IsHSet (Functor a0.1 a)}
     : LCC_Builder a (@sub_pre_cat _ P HF) (@lax_slice_category_over _ P HF a _) | 10
-      := I.
+      := tt.
 
     Global Instance LCC_coslice_over `{Funext}
            P `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}
            a
            `{forall a0 : @sub_pre_cat _ P HF, IsHSet (Functor a a0.1)}
     : LCC_Builder (@sub_pre_cat _ P HF) a (@lax_coslice_category_over _ P HF a _) | 10
-      := I.
+      := tt.
 
-    Class OLCC_Builder {A B C} (x : A) (y : B) (z : C) : Set := olcc_builder_dummy : True.
+    Class OLCC_Builder {A B C} (x : A) (y : B) (z : C) : Set := olcc_builder_dummy : Unit.
 
     Definition get_OLCC `{@OLCC_Builder A B C x y z} : C := z.
 
@@ -220,31 +220,31 @@ Module Export LaxCommaCoreNotations.
            (S : Pseudofunctor A) (T : Pseudofunctor B)
            {_ : forall a b, IsHSet (Functor (S a) (T b))}
     : OLCC_Builder S T (lax_comma_category S T) | 1000
-      := I.
+      := tt.
 
     Global Instance OLCC_slice `{Funext} A x (F : Pseudofunctor A)
            `{forall a0, IsHSet (Functor (F a0) x)}
     : OLCC_Builder F x (lax_slice_category x F) | 100
-      := I.
+      := tt.
 
     Global Instance OLCC_coslice `{Funext} A x (F : Pseudofunctor A)
            `{forall a0, IsHSet (Functor x (F a0))}
     : OLCC_Builder x F (lax_coslice_category x F) | 100
-      := I.
+      := tt.
 
     Global Instance OLCC_slice_over `{Funext}
            P `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}
            a
            `{forall a0 : @sub_pre_cat _ P HF, IsHSet (Functor a0.1 a)}
     : OLCC_Builder a (@sub_pre_cat _ P HF) (@lax_slice_category_over _ P HF a _) | 10
-      := I.
+      := tt.
 
     Global Instance OLCC_coslice_over `{Funext}
            P `{HF : forall C D, P C -> P D -> IsHSet (Functor C D)}
            a
            `{forall a0 : @sub_pre_cat _ P HF, IsHSet (Functor a a0.1)}
     : OLCC_Builder (@sub_pre_cat _ P HF) a (@lax_coslice_category_over _ P HF a _) | 10
-      := I.
+      := tt.
   End tc_notation_boiler_plate.
 
   (** We really want to use infix [⇓] and [⇑] for lax comma categories, but that's unicode.  Infix [,] might also be reasonable, but I can't seem to get it to work without destroying the [(_, _)] notation for ordered pairs.  So I settle for the ugly ASCII rendition [//] of [⇓] and [\\] for [⇑]. *)
diff --git a/theories/Categories/Monoidal/MonoidalCategory.v b/theories/Categories/Monoidal/MonoidalCategory.v
index 4d7465448f8..f7c9e6d7227 100644
--- a/theories/Categories/Monoidal/MonoidalCategory.v
+++ b/theories/Categories/Monoidal/MonoidalCategory.v
@@ -21,7 +21,7 @@ Section MonoidalCategoryConcepts.
   Variable tensor : ((C * C) -> C)%category.
   Variable I : C.
   
-  Local Notation "A ⊗ B" := (tensor (Datatypes.pair A B)).
+  Local Notation "A ⊗ B" := (tensor (Basics.Overture.pair A B)).
 
   Local Open Scope functor_scope.
   Definition right_assoc := (tensor ∘ (Functor.Prod.pair 1 tensor) )%functor.
diff --git a/theories/Categories/NatCategory.v b/theories/Categories/NatCategory.v
index 686f091a0f7..0a2e08aa550 100644
--- a/theories/Categories/NatCategory.v
+++ b/theories/Categories/NatCategory.v
@@ -18,7 +18,7 @@ Module Export Core.
     match n with
       | 0 => Empty
       | 1 => Unit
-      | S n' => (CardinalityRepresentative n' + Unit)%type
+      | S n' => CardinalityRepresentative n' + Unit
     end.
 
   Coercion CardinalityRepresentative : nat >-> Sortclass.
diff --git a/theories/Categories/NaturalTransformation/Core.v b/theories/Categories/NaturalTransformation/Core.v
index 038dbe09721..cc189cd9a8b 100644
--- a/theories/Categories/NaturalTransformation/Core.v
+++ b/theories/Categories/NaturalTransformation/Core.v
@@ -59,8 +59,8 @@ Bind Scope natural_transformation_scope with NaturalTransformation.
 
 Create HintDb natural_transformation discriminated.
 
-Global Arguments components_of {C D}%category {F G}%functor T%natural_transformation /
-          c%object : rename.
+Global Arguments components_of {C D}%_category {F G}%_functor T%_natural_transformation /
+          c%_object : rename.
 Global Arguments commutes {C D F G} !T / _ _ _ : rename.
 Global Arguments commutes_sym {C D F G} !T / _ _ _ : rename.
 
diff --git a/theories/Categories/NaturalTransformation/Sum.v b/theories/Categories/NaturalTransformation/Sum.v
index 09c716baa8b..ecdccf6f055 100644
--- a/theories/Categories/NaturalTransformation/Sum.v
+++ b/theories/Categories/NaturalTransformation/Sum.v
@@ -16,8 +16,8 @@ Section sum.
     refine (Build_NaturalTransformation
               (F + F') (G + G')
               (fun x => match x with
-                          | Datatypes.inl c => T c
-                          | Datatypes.inr c' => T' c'
+                          | Basics.Overture.inl c => T c
+                          | Basics.Overture.inr c' => T' c'
                         end)
               _).
     abstract (
diff --git a/theories/Categories/ProductLaws.v b/theories/Categories/ProductLaws.v
index 88884bcb4a3..eb4f4564285 100644
--- a/theories/Categories/ProductLaws.v
+++ b/theories/Categories/ProductLaws.v
@@ -10,10 +10,10 @@ Set Asymmetric Patterns.
 Local Open Scope category_scope.
 Local Open Scope functor_scope.
 
-Local Notation prod_type := Basics.Datatypes.prod.
-Local Notation fst_type := Basics.Datatypes.fst.
-Local Notation snd_type := Basics.Datatypes.snd.
-Local Notation pair_type := Basics.Datatypes.pair.
+Local Notation prod_type := Basics.Overture.prod.
+Local Notation fst_type := Basics.Overture.fst.
+Local Notation snd_type := Basics.Overture.snd.
+Local Notation pair_type := Basics.Overture.pair.
 
 (** ** Swap functor [C × D → D × C] *)
 Module Swap.
diff --git a/theories/Categories/Pseudofunctor/Core.v b/theories/Categories/Pseudofunctor/Core.v
index 5b41c590496..e988525a591 100644
--- a/theories/Categories/Pseudofunctor/Core.v
+++ b/theories/Categories/Pseudofunctor/Core.v
@@ -194,8 +194,8 @@ Bind Scope pseudofunctor_scope with Pseudofunctor.
 
 Create HintDb pseudofunctor discriminated.
 
-Arguments p_object_of {_} {C%category} F%pseudofunctor / c%object : rename.
-Arguments p_morphism_of {_} {C%category} F%pseudofunctor / {s d}%object m%morphism : rename.
+Arguments p_object_of {_} {C%_category} F%_pseudofunctor / c%_object : rename.
+Arguments p_morphism_of {_} {C%_category} F%_pseudofunctor / {s d}%_object m%_morphism : rename.
 
 (*Notation "F ₀ x" := (p_object_of F x) : object_scope.
 Notation "F ₁ m" := (p_morphism_of F m) : morphism_scope.*)
diff --git a/theories/Categories/PseudonaturalTransformation/Core.v b/theories/Categories/PseudonaturalTransformation/Core.v
index 7f03f17dfe2..60a52510296 100644
--- a/theories/Categories/PseudonaturalTransformation/Core.v
+++ b/theories/Categories/PseudonaturalTransformation/Core.v
@@ -221,8 +221,8 @@ Bind Scope pseudonatural_transformation_scope with PseudonaturalTransformation.
 
 Create HintDb pseuodnatural_transformation discriminated.
 
-Arguments p_components_of {_} {X}%category {F G}%pseudofunctor T%pseudonatural_transformation
-          a%object : rename, simpl nomatch.
+Arguments p_components_of {_} {X}%_category {F G}%_pseudofunctor T%_pseudonatural_transformation
+          a%_object : rename, simpl nomatch.
 
 #[export]
 Hint Resolve p_commutes_respects_identity p_commutes_respects_composition : category pseudonatural_transformation.
diff --git a/theories/Categories/Structure/IdentityPrinciple.v b/theories/Categories/Structure/IdentityPrinciple.v
index 5da2d87b743..dd3e7900c10 100644
--- a/theories/Categories/Structure/IdentityPrinciple.v
+++ b/theories/Categories/Structure/IdentityPrinciple.v
@@ -2,7 +2,7 @@
 Require Import Category.Core Category.Univalent Category.Morphisms.
 Require Import Structure.Core.
 Require Import Types.Sigma Trunc Equivalences.
-Require Import Basics.Tactics.
+Require Import Basics.Iff Basics.Tactics.
 
 Set Universe Polymorphism.
 Set Implicit Arguments.
diff --git a/theories/Classes/implementations/binary_naturals.v b/theories/Classes/implementations/binary_naturals.v
index 246a4e61f6e..7ab8f25db7b 100644
--- a/theories/Classes/implementations/binary_naturals.v
+++ b/theories/Classes/implementations/binary_naturals.v
@@ -1,5 +1,5 @@
 Require Import
-        HoTT.Spaces.Nat.
+        HoTT.Spaces.Nat.Core.
 Require Import
         HoTT.Tactics.
 Require Import
@@ -275,7 +275,7 @@ Section semiring_laws.
     apply (istrunc_isequiv_istrunc nat binary).
   Qed.
 
-  Global Instance binnat_semiring : IsSemiRing binnat.
+  Global Instance binnat_semiring : IsSemiCRing binnat.
   Proof.
     split; try split; try split; try split; hnf; intros.
     1, 5: apply istrunc_S; intros x y; exact (binnat_set x y).
@@ -363,7 +363,7 @@ Section naturals.
 
   Section for_another_semiring.
     Universe U.
-    Context {R:Type} `{IsSemiRing R}.
+    Context {R:Type} `{IsSemiCRing R}.
 
     Notation toR := (naturals_to_semiring binnat R).
     Notation toR_fromnat := (naturals_to_semiring nat R).
diff --git a/theories/Classes/implementations/family_prod.v b/theories/Classes/implementations/family_prod.v
index 7a30f3a3798..7c0ddc2aab4 100644
--- a/theories/Classes/implementations/family_prod.v
+++ b/theories/Classes/implementations/family_prod.v
@@ -1,7 +1,9 @@
 Require Import
   HoTT.Utf8Minimal
   HoTT.Basics.Overture Types.Unit
-  HoTT.Classes.implementations.list.
+  HoTT.Spaces.List.Core.
+
+Local Open Scope list_scope.
 
 (** The following section implements a datatype [FamilyProd] which
     is a kind of product/tuple. *)
@@ -43,7 +45,7 @@ Section family_prod.
   Fixpoint for_all_family_prod (F : I → Type) {ℓ : list I}
       (P : ∀ i, F i -> Type) : FamilyProd F ℓ → Type :=
     match ℓ with
-    | nil => λ _, True
+    | nil => λ _, Unit
     | i :: _ => λ '(x,s), P i x ∧ for_all_family_prod F P s
     end.
 
@@ -54,7 +56,7 @@ Section family_prod.
       (R : ∀ i, F i -> G i -> Type)
       : FamilyProd F ℓ → FamilyProd G ℓ → Type :=
     match ℓ with
-    | nil => λ _ _, True
+    | nil => λ _ _, Unit 
     | i :: _ => λ '(x,s) '(y,t), R i x y ∧ for_all_2_family_prod F G R s t
     end.
 
diff --git a/theories/Classes/implementations/field_of_fractions.v b/theories/Classes/implementations/field_of_fractions.v
index 2ba7aba1a3d..876570370d5 100644
--- a/theories/Classes/implementations/field_of_fractions.v
+++ b/theories/Classes/implementations/field_of_fractions.v
@@ -1,4 +1,4 @@
-Require Import HoTT.HIT.quotient HoTT.Basics.Trunc.
+Require Import HoTT.HIT.quotient.
 Require Import 
   HoTT.Classes.interfaces.abstract_algebra
   HoTT.Classes.theory.dec_fields.
@@ -301,7 +301,7 @@ Definition F_rec2@{i j} {T:Type@{i} } {sT : IsHSet T}
   (dequiv : forall x1 x2, equiv x1 x2 -> forall y1 y2, equiv y1 y2 ->
     dclass x1 y1 = dclass x2 y2),
   F -> F -> T
-  := @quotient_rec2@{UR UR j i} _ _ _ _ _ (Build_HSet _).
+  := @quotient_rec2@{UR UR UR j i} _ _ _ _ _ (Build_HSet _).
 
 Definition F_rec2_compute {T sT} dclass dequiv x y
   : @F_rec2 T sT dclass dequiv (' x) (' y) = dclass x y
@@ -344,7 +344,7 @@ hnf. apply (F_ind2 _).
 intros;apply path, Frac.pl_comm.
 Qed.
 
-Instance F_ring@{} : IsRing F.
+Instance F_ring@{} : IsCRing F.
 Proof.
 repeat split;
 first [change sg_op with mult; change mon_unit with 1|
@@ -400,7 +400,7 @@ Defined.
 
 Lemma classes_eq_related@{} : forall q r, ' q = ' r -> equiv q r.
 Proof.
-apply classes_eq_related@{UR UR Ularge Uhuge};apply _.
+apply classes_eq_related@{UR UR Ularge UR Ularge};apply _.
 Qed.
 
 Lemma class_neq@{} : forall q r, ~ (equiv q r) -> ' q <> ' r.
diff --git a/theories/Classes/implementations/list.v b/theories/Classes/implementations/list.v
deleted file mode 100644
index bb66aacd2f2..00000000000
--- a/theories/Classes/implementations/list.v
+++ /dev/null
@@ -1,140 +0,0 @@
-Require Import
-  HoTT.Classes.interfaces.abstract_algebra.
-
-Generalizable Variables A B C.
-
-Open Scope list_scope.
-
-(** Standard notations for lists. 
-In a special module to avoid conflicts. *)
-Module ListNotations.
-Notation " [] " := nil : list_scope.
-Notation " [ x ] " := (cons x nil) : list_scope.
-Notation " [ x ; y ; .. ; z ] " :=  (cons x (cons y .. (cons z nil) ..))
-  : list_scope.
-End ListNotations.
-
-Import ListNotations.
-
-Fixpoint length {A} (l : list A) := match l with
-  | [] => O
-  | _ :: l => S (length l)
-  end.
-
-Fixpoint fold_left {A B} (f : A -> B -> A) (acc : A) (l : list B) :=
-  match l with
-  | [] => acc
-  | x :: l => fold_left f (f acc x) l
-  end.
-
-Fixpoint map {A B} (f : A -> B) (l : list A) :=
-  match l with
-  | [] => []
-  | x :: l => (f x) :: (map f l)
-  end.
-
-Fixpoint map2 `(f : A -> B -> C)
-  (def_l : list A -> list C) (def_r : list B -> list C)
-  l1 l2 :=
-  match l1, l2 with
-  | [], [] => []
-  | [], _ => def_r l2
-  | _, [] => def_l l1
-  | x :: l1, y :: l2 => (f x y) :: (map2 f def_l def_r l1 l2)
-  end.
-
-Lemma map2_cons `(f : A -> B -> C) defl defr x l1 y l2 :
-  map2 f defl defr (x::l1) (y::l2) = (f x y) :: map2 f defl defr l1 l2.
-Proof.
-reflexivity.
-Qed.
-
-Lemma map_id `(f : A -> A) (Hf : forall x, f x = x) (l : list A) : map f l = l.
-Proof.
-induction l as [|x l IHl].
-- reflexivity.
-- simpl. rewrite Hf,IHl. reflexivity.
-Qed.
-
-Global Instance sg_op_app A : SgOp (list A) := @app A.
-
-Global Instance app_assoc A : Associative (@app A).
-Proof.
-intros l1. induction l1 as [|x l1 IH];intros l2 l3.
-- reflexivity.
-- simpl;apply ap;apply IH.
-Qed.
-
-Fixpoint for_all {A} (P : A -> Type) l : Type :=
-  match l with
-  | [] => Unit
-  | x :: l => P x /\ for_all P l
-  end.
-
-Lemma for_all_trivial {A} (P : A -> Type) : (forall x, P x) ->
-  forall l, for_all P l.
-Proof.
-intros HP l;induction l as [|x l IHl];split;auto.
-Qed.
-
-Lemma for_all_map {A B} P Q (f : A -> B) (Hf : forall x, P x -> Q (f x))
- : forall l, for_all P l -> for_all Q (map f l).
-Proof.
-intros l;induction l as [|x l IHl];simpl.
-- auto.
-- intros [Hx Hl]. split;auto.
-Defined.
-
-Lemma for_all_map2 {A B C} P Q R
-  `(f : A -> B -> C) (Hf : forall x y, P x -> Q y -> R (f x y))
-  def_l (Hdefl : forall l1, for_all P l1 -> for_all R (def_l l1))
-  def_r (Hdefr : forall l2, for_all Q l2 -> for_all R (def_r l2))
-  : forall l1 l2, for_all P l1 -> for_all Q l2 ->
-    for_all R (map2 f def_l def_r l1 l2).
-Proof.
-intros l1;induction l1 as [|x l1 IHl1].
-- simpl. intros [|y l2] _; auto.
-- simpl. intros [|y l2] [Hx Hl1];[intros _|intros [Hy Hl2]];simpl;auto.
-  apply Hdefl. simpl;auto.
-Qed.
-
-Lemma fold_preserves {A B} P Q (f : A -> B -> A)
-  (Hf : forall x y, P x -> Q y -> P (f x y))
-  : forall acc (Ha : P acc) l (Hl : for_all Q l), P (fold_left f acc l).
-Proof.
-intros acc Ha l Hl;revert l Hl acc Ha.
-intros l;induction l as [|x l IHl].
-- intros _ acc Ha. exact Ha.
-- simpl. intros [Hx Hl] acc Ha.
-  apply IHl;auto.
-Qed.
-
-Global Instance for_all_trunc {A} {n} (P : A -> Type) : forall l,
-  for_all (fun x => IsTrunc n (P x)) l -> IsTrunc n (for_all P l).
-Proof.
-intros l;induction l as [|x l IHl];simpl.
-- intros _. destruct n;apply _.
-- intros [Hx Hl].
-  apply IHl in Hl. apply _.
-Qed.
-
-(* Copy pasted from the Coq library. *)
-Definition tl {A} (l:list A) : list A :=
-  match l with
-    | [] => nil
-    | a :: m => m
-  end.
-
-(* Modified copy from the Coq library. *)
-(** The "In list" predicate *)
-Fixpoint InList {A} (a:A) (l:list A) : Type0 :=
-  match l with
-    | [] => False
-    | b :: m => b = a |_| InList a m
-  end.
-
-Fixpoint fold_right {A} {B} (f : B -> A -> A) (x : A) (l : list B) : A :=
-  match l with
-    | nil => x
-    | cons b t => f b (fold_right f x t)
-  end.
diff --git a/theories/Classes/implementations/natpair_integers.v b/theories/Classes/implementations/natpair_integers.v
index 1c7efea54da..1a5bbe73d35 100644
--- a/theories/Classes/implementations/natpair_integers.v
+++ b/theories/Classes/implementations/natpair_integers.v
@@ -1,5 +1,5 @@
 Require Import HoTT.HIT.quotient
-  HoTT.TruncType HoTT.Basics.Trunc.
+  HoTT.TruncType.
 Require Import
   HoTT.Classes.implementations.peano_naturals
   HoTT.Classes.interfaces.abstract_algebra
@@ -257,7 +257,7 @@ trivial;apply symmetry;trivial.
 Qed.
 
 Section to_ring.
-Context {B : Type@{UNalt} } `{IsRing@{UNalt} B}.
+Context {B : Type@{UNalt} } `{IsCRing@{UNalt} B}.
 
 Definition to_ring@{} : T N -> B.
 Proof.
@@ -312,7 +312,7 @@ Definition Z_path {x y} : PairT.equiv x y -> Z_of_pair x = Z_of_pair y
   := related_classes_eq _.
 
 Definition related_path {x y} : Z_of_pair x = Z_of_pair y -> PairT.equiv x y
-  := classes_eq_related@{UN UN Ularge Uhuge} _ _ _.
+  := classes_eq_related@{UN UN Ularge UN Ularge} _ _ _.
 
 Definition Z_rect@{i} (P : Z -> Type@{i}) {sP : forall x, IsHSet (P x)}
   (dclass : forall x : PairT.T N, P (' x))
@@ -368,7 +368,7 @@ Definition Z_rec2@{i j} {T:Type@{i} } {sT : IsHSet T}
   (dequiv : forall x1 x2, PairT.equiv x1 x2 -> forall y1 y2, PairT.equiv y1 y2 ->
     dclass x1 y1 = dclass x2 y2),
   Z -> Z -> T
-  := @quotient_rec2@{UN UN j i} _ _ _ _ _ (Build_HSet _).
+  := @quotient_rec2@{UN UN UN j i} _ _ _ _ _ (Build_HSet _).
 
 Definition Z_rec2_compute {T sT} dclass dequiv x y
   : @Z_rec2 T sT dclass dequiv (' x) (' y) = dclass x y
@@ -426,7 +426,7 @@ Defined.
 Definition Z_negate_compute q : - (' q) = ' (PairT.opp _ q)
   := 1.
 
-Lemma Z_ring@{} : IsRing Z.
+Lemma Z_ring@{} : IsCRing Z.
 Proof.
   repeat split.
   1,8: exact _.
@@ -862,7 +862,7 @@ eapply Z_rec.
 apply (PairT.to_ring_respects N).
 Defined.
 
-Lemma Z_to_ring_morphism' `{IsRing B} : IsSemiRingPreserving (integers_to_ring Z B).
+Lemma Z_to_ring_morphism' `{IsCRing B} : IsSemiRingPreserving (integers_to_ring Z B).
 Proof.
 split;split;red.
 - change (@sg_op B _) with (@plus B _);
@@ -899,11 +899,11 @@ split;split;red.
   rewrite negate_0,plus_0_r;trivial.
 Qed.
 
-Instance Z_to_ring_morphism@{} `{IsRing B} : IsSemiRingPreserving (integers_to_ring Z B)
+Instance Z_to_ring_morphism@{} `{IsCRing B} : IsSemiRingPreserving (integers_to_ring Z B)
   := ltac:(first [exact Z_to_ring_morphism'@{Ularge}|
                   exact Z_to_ring_morphism'@{}]).
 
-Lemma Z_to_ring_unique@{} `{IsRing B} (h : Z -> B) `{!IsSemiRingPreserving h}
+Lemma Z_to_ring_unique@{} `{IsCRing B} (h : Z -> B) `{!IsSemiRingPreserving h}
   : forall x : Z, integers_to_ring Z B x = h x.
 Proof.
 pose proof Z_ring.
diff --git a/theories/Classes/implementations/ne_list.v b/theories/Classes/implementations/ne_list.v
index 607336393c6..d4183d4daee 100644
--- a/theories/Classes/implementations/ne_list.v
+++ b/theories/Classes/implementations/ne_list.v
@@ -1,8 +1,8 @@
 Require Import
   HoTT.Utf8Minimal
-  HoTT.Classes.implementations.list
-  HoTT.Basics.Overture
-  HoTT.Spaces.Nat.
+  HoTT.Spaces.List.Core
+  HoTT.Basics.Overture Basics.Tactics
+  HoTT.Spaces.Nat.Core.
 
 Local Open Scope nat_scope.
 Local Open Scope type_scope.
@@ -56,7 +56,7 @@ Section with_type.
   Fixpoint from_list (x: T) (xs: list T): ne_list :=
     match xs with
     | nil => one x
-    | Datatypes.cons h t => cons x (from_list h t)
+    | List.Core.cons h t => cons x (from_list h t)
     end.
 
   Definition tail (l: ne_list): list T
@@ -107,8 +107,8 @@ Section with_type.
      + intro. apply Pmore; intros; apply IHl.
   Qed.
 
-  Lemma tl_length (l: ne_list)
-    : S (length (tl (to_list l))) = length (to_list l).
+  Lemma tail_length (l: ne_list)
+    : S (length (List.Core.tail (to_list l))) = length (to_list l).
   Proof. destruct l; reflexivity. Qed.
 End with_type.
 
@@ -123,12 +123,14 @@ Fixpoint tails {T} (l: ne_list T): ne_list (ne_list T) :=
 Lemma tails_are_shorter {T} (y x: ne_list T):
   InList x (to_list (tails y)) →
   leq (length (to_list x)) (length (to_list y)).
-Proof with auto.
- induction y; cbn.
- - intros [[] | C].
-   + constructor.
-   + elim C.
- - intros [[] | C]...
+Proof.
+  induction y; cbn.
+  - intros [[] | C].
+    + constructor.
+    + elim C.
+  - intros [[] | C].
+    + exact _.
+    + by apply leq_succ_r, IHy.
 Qed.
 
 Fixpoint map {A B} (f: A → B) (l: ne_list A): ne_list B :=
@@ -138,7 +140,7 @@ Fixpoint map {A B} (f: A → B) (l: ne_list A): ne_list B :=
   end.
 
 Lemma list_map {A B} (f: A → B) (l: ne_list A)
-  : to_list (map f l) = list.map f (to_list l).
+  : to_list (map f l) = List.Core.list_map f (to_list l).
 Proof.
   induction l.
   - reflexivity.
diff --git a/theories/Classes/implementations/peano_naturals.v b/theories/Classes/implementations/peano_naturals.v
index 563eea22c9d..085611f76a5 100644
--- a/theories/Classes/implementations/peano_naturals.v
+++ b/theories/Classes/implementations/peano_naturals.v
@@ -28,105 +28,138 @@ Defined.
 Global Instance nat_0: Zero@{N} nat := 0%nat.
 Global Instance nat_1: One@{N} nat := 1%nat.
 
-Global Instance nat_plus: Plus@{N} nat := Nat.Core.add.
+Global Instance nat_plus: Plus@{N} nat := Nat.Core.nat_add.
 
-Notation mul := Nat.Core.mul.
+Notation mul := Nat.Core.nat_mul.
 
-Global Instance nat_mult: Mult@{N} nat := Nat.Core.mul.
+Global Instance nat_mult: Mult@{N} nat := Nat.Core.nat_mul.
 
 Ltac simpl_nat :=
-  change (@plus nat _) with Nat.Core.add;
-  change (@mult nat _) with Nat.Core.mul;
+  change (@plus nat _) with Nat.Core.nat_add;
+  change (@mult nat _) with Nat.Core.nat_mul;
   simpl;
-  change Nat.Core.add with (@plus nat Nat.Core.add);
-  change Nat.Core.mul with (@mult nat Nat.Core.mul).
+  change Nat.Core.nat_add with (@plus nat Nat.Core.nat_add);
+  change Nat.Core.nat_mul with (@mult nat Nat.Core.nat_mul).
 
-Local Instance add_assoc : Associative@{N} (plus : Plus nat).
-Proof.
-hnf. apply (nat_rect@{N} (fun a => forall b c, _));[|intros a IH];
-intros b c.
-+ reflexivity.
-+ change (S (a + (b + c)) = S (a + b + c)).
-  apply ap,IH.
-Qed.
+(** [0 + a =N= a] *)
+Local Instance add_0_l : LeftIdentity@{N N} (plus : Plus nat) 0 := fun _ => idpath.
+
+Definition add_S_l a b : S a + b =N= S (a + b) := idpath.
 
-Lemma add_0_r : forall x:nat, x + 0 =N= x.
+(** [a + 0 =N= a] *)
+Local Instance add_0_r : RightIdentity@{N N} (plus : Plus nat) (zero : Zero nat).
 Proof.
-intros a;induction a as [|a IH].
-+ reflexivity.
-+ apply (ap S),IH.
+  intros a; induction a as [| a IHa].
+  - reflexivity.
+  - apply (ap S), IHa.
 Qed.
 
 Lemma add_S_r : forall a b, a + S b =N= S (a + b).
 Proof.
-induction a as [|a IHa];intros b.
-- reflexivity.
-- simpl_nat. apply (ap S),IHa.
+  intros a b; induction a as [| a IHa].
+  - reflexivity.
+  - apply (ap S), IHa.
 Qed.
 
-Lemma add_S_l a b : S a + b =N= S (a + b).
-Proof. exact idpath. Qed.
-
-Lemma add_0_l a : 0 + a =N= a.
-Proof. exact idpath. Qed.
+(** [forall a b c : nat, a + (b + c) = (a + b) + c].  The RHS is written [a + b + c]. *)
+Local Instance add_assoc : Associative@{N} (plus : Plus nat).
+Proof.
+  intros a b c; induction a as [| a IHa].
+  - reflexivity.
+  - change (S (a + (b + c)) = S (a + b + c)).
+    apply (ap S), IHa.
+Qed.
 
 Local Instance add_comm : Commutative@{N N} (plus : Plus nat).
 Proof.
-hnf. apply (nat_rect@{N} (fun a => forall b, _));[|intros a IHa];
-intros b;induction b as [|b IHb].
-- reflexivity.
-- change (S b = S (b + 0)). apply ap,IHb.
-- apply (ap S),IHa.
-- change (S (a + S b) = S (b + S a)).
-  rewrite (IHa (S b)), <- (IHb ). apply (ap S),(ap S),symmetry,IHa.
+  intros a b; induction a as [| a IHa].
+  - rhs apply add_0_r.
+    reflexivity.
+  - rhs apply add_S_r.
+    apply (ap S), IHa.
 Qed.
 
-Local Instance add_mul_distr_l : LeftDistribute@{N}
-  (mult :Mult nat) (plus:Plus nat).
+Local Instance mul_0_l : LeftAbsorb@{N N} (mult : Mult nat) (zero : Zero nat)
+  := fun _ => idpath.
+
+Definition mul_S_l a b : (S a) * b =N= b + a * b := idpath.
+
+(** [1 * a =N= a]. *)
+Local Instance mul_1_l : LeftIdentity@{N N} (mult : Mult nat) (one : One nat)
+  := add_0_r.
+
+Local Instance mul_0_r : RightAbsorb@{N N} (mult : Mult nat) (zero : Zero nat).
 Proof.
-hnf. apply (nat_rect@{N} (fun a => forall b c, _));[|intros a IHa];
-simpl_nat.
-- intros _ _;reflexivity.
-- intros. rewrite IHa.
-  rewrite <-(associativity b), (associativity c), (commutativity c),
-  <-(associativity (a*b)), (associativity b).
-  reflexivity.
+  intros a; induction a as [| a IHa].
+  - reflexivity.
+  - change (a * 0 = 0).
+    exact IHa.
 Qed.
 
-Lemma mul_0_r : forall a : nat, a * 0 =N= 0.
+Lemma mul_S_r a b : a * S b =N= a + a * b.
 Proof.
-induction a;simpl_nat;trivial.
-reflexivity.
+  induction a as [| a IHa].
+  - reflexivity.
+  - change (S (b + a * S b) = S (a + (b + a * b))).
+    apply (ap S).
+    rhs rapply add_assoc.
+    rhs rapply (ap (fun x => x + _) (add_comm _ _)).
+    rhs rapply (add_assoc _ _ _)^.
+    exact (ap (plus b) IHa).
 Qed.
 
-Lemma mul_S_r : forall a b : nat, a * S b =N= a + a * b.
+(** [a * 1 =N= a]. *)
+Local Instance mul_1_r : RightIdentity@{N N} (mult : Mult nat) (one : One nat).
 Proof.
-apply (nat_rect@{N} (fun a => forall b, _));[|intros a IHa];intros b;simpl_nat.
-- reflexivity.
-- simpl_nat. rewrite IHa.
-  rewrite (simple_associativity b a).
-  change (((b + a) + (a * b)).+1 =N= (a + Nat.Core.add b (a * b)).+1).
-  rewrite (commutativity (f:=plus) b a), <-(associativity a b).
-  reflexivity.
+  intros a.
+  lhs nrapply mul_S_r.
+  lhs nrapply (ap _ (mul_0_r a)).
+  apply add_0_r.
 Qed.
 
 Local Instance mul_comm : Commutative@{N N} (mult : Mult nat).
 Proof.
-hnf. apply (nat_rect@{N} (fun a => forall b, _));[|intros a IHa];simpl_nat.
-- intros;apply symmetry,mul_0_r.
-- intros b;rewrite IHa. rewrite mul_S_r,<-IHa. reflexivity.
+  intros a b; induction a as [| a IHa].
+  - rhs apply mul_0_r.
+    reflexivity.
+  - rhs apply mul_S_r.
+    change (b + a * b = b + b * a).
+    apply (ap (fun x => b + x)), IHa.
 Qed.
 
+(** [a * (b + c) =N= a * b + a * c]. *)
+Local Instance add_mul_distr_l
+  : LeftDistribute@{N} (mult : Mult nat) (plus : Plus nat).
+Proof.
+  intros a b c; induction a as [| a IHa].
+  - reflexivity.
+  - change ((b + c) + a * (b + c) = (b + a * b) + (c + a * c)).
+    lhs rapply (add_assoc _ _ _)^.
+    rhs rapply (add_assoc _ _ _)^.
+    apply (ap (plus b)).
+    rhs rapply add_assoc.
+    rhs rapply (ap (fun x => x + _) (add_comm _ _)).
+    rhs rapply (add_assoc _ _ _)^.
+    apply (ap (plus c)), IHa.
+Qed.
+
+(** [(a + b) * c =N= a * c + b * c].  This also follows from [plus_mult_distr_r], which currently requires that we already have a semiring.  It should be adjusted to not require associativity. *)
+Local Instance add_mul_distr_r
+  : RightDistribute@{N} (mult : Mult nat) (plus : Plus nat).
+Proof.
+  intros a b c.
+  lhs apply mul_comm.
+  lhs apply add_mul_distr_l.
+  apply ap011; apply mul_comm.
+Defined.
+
 Local Instance mul_assoc : Associative@{N} (mult : Mult nat).
 Proof.
-hnf. apply (nat_rect@{N} (fun a => forall b c, _));[|intros a IHa].
-- intros;reflexivity.
-- unfold mult;simpl;change nat_mult with mult.
-  intros b c.
-  rewrite (mul_comm (_ + _) c).
-  rewrite add_mul_distr_l.
-  rewrite (mul_comm c (a*b)).
-  rewrite <-IHa. rewrite (mul_comm b c). reflexivity.
+ intros a b c; induction a as [| a IHa].
+  - reflexivity.
+  - simpl_nat.
+    rhs apply add_mul_distr_r.
+    apply ap, IHa.
 Qed.
 
 Global Instance S_neq_0 x : PropHolds (~ (S x =N= 0)).
@@ -143,6 +176,7 @@ Definition pred x := match x with | 0%nat => 0 | S k => k end.
 Global Instance S_inj : IsInjective@{N N} S
   := { injective := fun a b E => ap pred E }.
 
+(** This is also in Spaces.Nat.Core. *)
 Global Instance nat_dec: DecidablePaths@{N} nat.
 Proof.
 hnf.
@@ -162,15 +196,9 @@ Proof.
 apply hset_pathcoll, pathcoll_decpaths, nat_dec.
 Qed.
 
-Instance nat_semiring : IsSemiRing@{N} nat.
+Instance nat_semiring : IsSemiCRing@{N} nat.
 Proof.
-repeat (split; try apply _);
-first [change sg_op with plus; change mon_unit with 0
-      |change sg_op with mult; change mon_unit with 1].
-- exact add_0_r.
-- exact add_0_r.
-- hnf;simpl_nat. intros a.
-  rewrite mul_S_r,mul_0_r. apply add_0_r.
+  repeat (split; try exact _).
 Qed.
 
 (* Add Ring nat: (rings.stdlib_semiring_theory nat). *)
@@ -246,7 +274,7 @@ Global Instance nat_lt: Lt@{N N} nat := Nat.Core.lt.
 Lemma le_plus : forall n k, n <= k + n.
 Proof.
 induction k.
-- apply Nat.Core.leq_n.
+- apply Nat.Core.leq_refl.
 - simpl_nat. constructor. assumption.
 Qed.
 
@@ -546,7 +574,7 @@ Definition nat_full@{} := ltac:(first[exact nat_full'@{Ularge Ularge}|
                                       exact nat_full'@{}]).
 Local Existing Instance nat_full.
 
-Lemma le_nat_max_l n m : n <= Nat.Core.max n m.
+Lemma le_nat_max_l n m : n <= Nat.Core.nat_max n m.
 Proof.
   revert m.
   induction n as [|n' IHn];
@@ -554,7 +582,7 @@ Proof.
   - apply zero_least.
   - apply le_S_S. exact (IHn m').
 Qed.
-Lemma le_nat_max_r n m : m <= Nat.Core.max n m.
+Lemma le_nat_max_r n m : m <= Nat.Core.nat_max n m.
 Proof.
   revert m.
   induction n as [|n' IHn];
@@ -580,7 +608,7 @@ Global Instance nat_naturals_to_semiring : NaturalsToSemiRing@{N i} nat :=
 
 Section for_another_semiring.
   Universe U.
-  Context {R:Type@{U} } `{IsSemiRing@{U} R}.
+  Context {R:Type@{U} } `{IsSemiCRing@{U} R}.
 
   Notation toR := (naturals_to_semiring nat R).
 
@@ -644,7 +672,7 @@ intros;apply toR_unique, _.
 Qed.
 Global Existing Instance nat_naturals.
 
-Global Instance nat_cut_minus: CutMinus@{N} nat := Nat.Core.sub.
+Global Instance nat_cut_minus: CutMinus@{N} nat := Nat.Core.nat_sub.
 
 Lemma plus_minus : forall a b, cut_minus (a + b) b =N= a.
 Proof.
diff --git a/theories/Classes/interfaces/abstract_algebra.v b/theories/Classes/interfaces/abstract_algebra.v
index 99a9b4d564d..99386f61ba2 100644
--- a/theories/Classes/interfaces/abstract_algebra.v
+++ b/theories/Classes/interfaces/abstract_algebra.v
@@ -1,10 +1,11 @@
+Require Export Basics.Classes Basics.Overture.
 Require Import Spaces.Nat.Core.
 Require Export HoTT.Classes.interfaces.canonical_names.
 Require Import Modalities.ReflectiveSubuniverse.
 
 Local Set Polymorphic Inductive Cumulativity.
 
-Generalizable Variables A B f g x y.
+Generalizable Variables A B C f g x y.
 
 (* 
 For various structures we omit declaration of substructures. For example, if we 
@@ -134,7 +135,7 @@ Section upper_classes.
 
   Context {Aplus : Plus A} {Amult : Mult A} {Azero : Zero A} {Aone : One A}.
 
-  Class IsSemiRing :=
+  Class IsSemiCRing :=
     { semiplus_monoid : @IsCommutativeMonoid plus_is_sg_op zero_is_mon_unit
     ; semimult_monoid : @IsCommutativeMonoid mult_is_sg_op one_is_mon_unit
     ; semiring_distr : LeftDistribute (.*.) (+)
@@ -143,17 +144,32 @@ Section upper_classes.
 
   Context {Anegate : Negate A}.
 
-  Class IsRing :=
-    { ring_group : @IsAbGroup plus_is_sg_op zero_is_mon_unit _
-    ; ring_monoid : @IsCommutativeMonoid mult_is_sg_op one_is_mon_unit
-    ; ring_dist : LeftDistribute (.*.) (+) }.
-  #[export] Existing Instances ring_group ring_monoid ring_dist.
+  Class IsRing := {
+    ring_abgroup :: @IsAbGroup plus_is_sg_op zero_is_mon_unit _;
+    ring_monoid :: @IsMonoid mult_is_sg_op one_is_mon_unit;
+    ring_dist_left :: LeftDistribute (.*.) (+);
+    ring_dist_right :: RightDistribute (.*.) (+);
+  }.
 
-  (* For now, we follow CoRN/ring_theory's example in having Ring and SemiRing
-    require commutative multiplication. *)
+  Class IsCRing :=
+    { cring_group : @IsAbGroup plus_is_sg_op zero_is_mon_unit _
+    ; cring_monoid : @IsCommutativeMonoid mult_is_sg_op one_is_mon_unit
+    ; cring_dist : LeftDistribute (.*.) (+) }.
 
+  #[export] Existing Instances cring_group cring_monoid cring_dist.
+  
+  Global Instance isring_iscring : IsCRing -> IsRing.
+  Proof.
+    intros H.
+    econstructor; try exact _.
+    intros a b c.
+    lhs rapply commutativity.
+    lhs rapply distribute_l.
+    f_ap; apply commutativity.
+  Defined.
+  
   Class IsIntegralDomain :=
-    { intdom_ring : IsRing
+    { intdom_ring : IsCRing
     ; intdom_nontrivial : PropHolds (not (1 = 0))
     ; intdom_nozeroes : NoZeroDivisors A }.
   #[export] Existing Instances intdom_nozeroes.
@@ -161,7 +177,7 @@ Section upper_classes.
   (* We do not include strong extensionality for (-) and (/)
     because it can de derived *)
   Class IsField {Aap: Apart A} {Arecip: Recip A} :=
-    { field_ring : IsRing
+    { field_ring : IsCRing
     ; field_apart : IsApart A
     ; field_plus_ext : StrongBinaryExtensionality (+)
     ; field_mult_ext : StrongBinaryExtensionality (.*.)
@@ -177,7 +193,7 @@ Section upper_classes.
     f (/x) = / (f x), / /x = x, /x * /y = /(x * y) 
     hold without any additional assumptions *)
   Class IsDecField {Adec_recip : DecRecip A} :=
-    { decfield_ring : IsRing
+    { decfield_ring : IsCRing
     ; decfield_nontrivial : PropHolds (1 <> 0)
     ; dec_recip_0 : /0 = 0
     ; dec_recip_inverse : forall x, x <> 0 -> x / x = 1 }.
@@ -187,7 +203,7 @@ Section upper_classes.
     := field_characteristic : forall n : nat,
         Nat.Core.lt 0 n ->
         iff@{j j j} (forall m : nat, not@{j} (paths@{Set} n
-                                                  (Nat.Core.mul k m)))
+                                                  (nat_mul k m)))
         (@apart A Aap (nat_iter n (1 +) 0) 0).
 
 End upper_classes.
@@ -204,13 +220,13 @@ Hint Extern 5 (PropHolds (1 <> 0)) =>
   eapply @decfield_nontrivial : typeclass_instances.
 
 (* 
-For a strange reason IsRing instances of Integers are sometimes obtained by
+For a strange reason IsCRing instances of Integers are sometimes obtained by
 Integers -> IntegralDomain -> Ring and sometimes directly. Making this an
-instance with a low priority instead of using intdom_ring:> IsRing forces Coq to
+instance with a low priority instead of using intdom_ring:> IsCRing forces Coq to
 take the right way 
 *)
 #[export]
-Hint Extern 10 (IsRing _) => apply @intdom_ring : typeclass_instances.
+Hint Extern 10 (IsCRing _) => apply @intdom_ring : typeclass_instances.
 
 Arguments recip_inverse {A Aplus Amult Azero Aone Anegate Aap Arecip IsField} _.
 Arguments dec_recip_inverse
@@ -331,26 +347,106 @@ Section morphism_classes.
   End latticemorphism_classes.
 End morphism_classes.
 
-Section jections.
-  Context {A B} (f : A -> B).
+Section id_mor.
+  Context `{SgOp A} `{MonUnit A}.
 
-  Class IsInjective := injective : forall x y, f x = f y -> x = y.
+  Global Instance id_sg_morphism : IsSemiGroupPreserving (@id A).
+  Proof.
+    split.
+  Defined.
 
-  Lemma isinjective_ne `{!IsInjective} x y :
-    x <> y -> f x <> f y.
+  Global Instance id_monoid_morphism : IsMonoidPreserving (@id A).
   Proof.
-    intros E1 E2. apply E1.
-    apply injective.
-    assumption.
-  Qed.
+    split; split.
+  Defined.
+End id_mor.
 
-End jections.
+Section compose_mor.
 
-Global Instance isinj_idmap A : @IsInjective A A idmap
-  := fun x y => idmap.
+  Context
+    `{SgOp A} `{MonUnit A}
+    `{SgOp B} `{MonUnit B}
+    `{SgOp C} `{MonUnit C}
+    (f : A -> B) (g : B -> C).
 
+  (** Making these global instances causes typeclass loops.  Instead they are declared below as [Hint Extern]s that apply only when the goal has the specified form. *)
+  Local Instance compose_sg_morphism : IsSemiGroupPreserving f -> IsSemiGroupPreserving g ->
+    IsSemiGroupPreserving (g ∘ f).
+  Proof.
+    red; intros fp gp x y.
+    unfold Compose.
+    refine ((ap g _) @ _).
+    - apply fp.
+    - apply gp.
+  Defined.
+
+  Local Instance compose_monoid_morphism : IsMonoidPreserving f -> IsMonoidPreserving g ->
+    IsMonoidPreserving (g ∘ f).
+  Proof.
+    intros;split.
+    - apply _.
+    - red;unfold Compose.
+      etransitivity;[|apply (preserves_mon_unit (f:=g))].
+      apply ap,preserves_mon_unit.
+  Defined.
+
+End compose_mor.
+
+Section invert_mor.
+
+  Context
+    `{SgOp A} `{MonUnit A}
+    `{SgOp B} `{MonUnit B}
+    (f : A -> B).
+
+  Local Instance invert_sg_morphism
+    : forall `{!IsEquiv f}, IsSemiGroupPreserving f ->
+      IsSemiGroupPreserving (f^-1).
+  Proof.
+    red; intros E fp x y.
+    apply (equiv_inj f).
+    refine (_ @ _ @ _ @ _)^.
+    - apply fp.
+    (* We could use [apply ap2; apply eisretr] here, but it is convenient
+       to have things in terms of ap. *)
+    - refine (ap (fun z => sg_op z _) _); apply eisretr.
+    - refine (ap (fun z => sg_op _ z) _); apply eisretr.
+    - symmetry; apply eisretr.
+  Defined.
+
+  Local Instance invert_monoid_morphism :
+    forall `{!IsEquiv f}, IsMonoidPreserving f -> IsMonoidPreserving (f^-1).
+  Proof.
+    intros;split.
+    - apply _.
+    - apply (equiv_inj f).
+      refine (_ @ _).
+      + apply eisretr.
+      + symmetry; apply preserves_mon_unit.
+  Defined.
+
+End invert_mor.
+
+#[export]
+Hint Extern 4 (IsSemiGroupPreserving (_ ∘ _)) =>
+  class_apply @compose_sg_morphism : typeclass_instances.
+#[export]
+Hint Extern 4 (IsMonoidPreserving (_ ∘ _)) =>
+  class_apply @compose_monoid_morphism : typeclass_instances.
+
+#[export]
+Hint Extern 4 (IsSemiGroupPreserving (_ o _)) =>
+  class_apply @compose_sg_morphism : typeclass_instances.
+#[export]
+Hint Extern 4 (IsMonoidPreserving (_ o _)) =>
+  class_apply @compose_monoid_morphism : typeclass_instances.
+
+#[export]
+Hint Extern 4 (IsSemiGroupPreserving (_^-1)) =>
+  class_apply @invert_sg_morphism : typeclass_instances.
 #[export]
-Hint Unfold IsInjective : typeclass_instances.
+Hint Extern 4 (IsMonoidPreserving (_^-1)) =>
+  class_apply @invert_monoid_morphism : typeclass_instances.
 
 #[export]
 Instance isinjective_mapinO_tr {A B : Type} (f : A -> B)
diff --git a/theories/Classes/interfaces/canonical_names.v b/theories/Classes/interfaces/canonical_names.v
index ec68bbbc61b..fb45c33e6a6 100644
--- a/theories/Classes/interfaces/canonical_names.v
+++ b/theories/Classes/interfaces/canonical_names.v
@@ -271,10 +271,6 @@ Class CoTransitive `(R : Relation A) : Type := cotransitive
   : forall x y, R x y -> forall z, hor (R x z) (R z y).
 Arguments cotransitive {A R CoTransitive x y} _ _.
 
-Class AntiSymmetric `(R : Relation A) : Type
-  := antisymmetry: forall x y, R x y -> R y x -> x = y.
-Arguments antisymmetry {A} _ {AntiSymmetric} _ _ _ _.
-
 Class EquivRel `(R : Relation A) : Type := Build_EquivRel
   { EquivRel_Reflexive : Reflexive R ;
     EquivRel_Symmetric : Symmetric R ;
diff --git a/theories/Classes/interfaces/cauchy.v b/theories/Classes/interfaces/cauchy.v
index 556eac1d5f2..9e4f9f35d3a 100644
--- a/theories/Classes/interfaces/cauchy.v
+++ b/theories/Classes/interfaces/cauchy.v
@@ -53,12 +53,12 @@ Section cauchy.
       assert (lim_close := is_limit x (epsilon / 2));
         strip_truncations.
       destruct lim_close as [N isclose'].
-      set (n := Nat.Core.max (M (epsilon / 2)) N).
+      set (n := Nat.Core.nat_max (M (epsilon / 2)) N).
       assert (leNn := le_nat_max_r (M (epsilon / 2)) N : N ≤ n).
       assert (isclose := isclose' n leNn).
       clear isclose'.
       assert (leMn := le_nat_max_l (M (epsilon / 2)) N : M (epsilon / 2) ≤ n).
-      assert (leMM : M (epsilon / 2) ≤ M (epsilon / 2) ) by apply (Nat.Core.leq_n).
+      assert (leMM : M (epsilon / 2) ≤ M (epsilon / 2) ) by apply (Nat.Core.leq_refl).
       assert (x_close := cauchy_convergence x (epsilon/2) n (M (epsilon / 2)) leMn leMM).
       cbn in isclose, x_close.
       rewrite (@preserves_mult Q F _ _ _ _ _ _ _ _ _ _ _ _) in isclose, x_close.
diff --git a/theories/Classes/interfaces/integers.v b/theories/Classes/interfaces/integers.v
index bd808e0a784..dc0527f5ea5 100644
--- a/theories/Classes/interfaces/integers.v
+++ b/theories/Classes/interfaces/integers.v
@@ -5,15 +5,15 @@ Require Import
   HoTT.Classes.theory.rings (* for Ring -> SemiRing *).
 
 Class IntegersToRing@{i j} (A:Type@{i})
-  := integers_to_ring: forall (R:Type@{j}) `{IsRing R}, A -> R.
+  := integers_to_ring: forall (R:Type@{j}) `{IsCRing R}, A -> R.
 Arguments integers_to_ring A {_} R {_ _ _ _ _ _} _.
 
 Class Integers A {Aap:Apart A} {Aplus Amult Azero Aone Anegate Ale Alt}
   `{U : IntegersToRing A} :=
-  { integers_ring : @IsRing A Aplus Amult Azero Aone Anegate
+  { integers_ring : @IsCRing A Aplus Amult Azero Aone Anegate
   ; integers_order : FullPseudoSemiRingOrder Ale Alt
-  ; integers_to_ring_mor : forall {B} `{IsRing B}, IsSemiRingPreserving (integers_to_ring A B)
-  ; integers_initial: forall {B} `{IsRing B} {h : A -> B} `{!IsSemiRingPreserving h} x,
+  ; integers_to_ring_mor : forall {B} `{IsCRing B}, IsSemiRingPreserving (integers_to_ring A B)
+  ; integers_initial: forall {B} `{IsCRing B} {h : A -> B} `{!IsSemiRingPreserving h} x,
       integers_to_ring A B x = h x}.
 #[export] Existing Instances integers_ring integers_order integers_to_ring_mor.
 
diff --git a/theories/Classes/interfaces/naturals.v b/theories/Classes/interfaces/naturals.v
index f6212d7ca16..74ba7d7ab06 100644
--- a/theories/Classes/interfaces/naturals.v
+++ b/theories/Classes/interfaces/naturals.v
@@ -3,17 +3,17 @@ Require Import
  HoTT.Classes.interfaces.orders.
 
 Class NaturalsToSemiRing@{i j} (A : Type@{i}) :=
-  naturals_to_semiring: forall (B : Type@{j}) `{IsSemiRing B}, A -> B.
+  naturals_to_semiring: forall (B : Type@{j}) `{IsSemiCRing B}, A -> B.
 
 Arguments naturals_to_semiring A {_} B {_ _ _ _ _} _.
 
 Class Naturals A {Aap:Apart A} {Aplus Amult Azero Aone Ale Alt}
   `{U: NaturalsToSemiRing A} :=
-  { naturals_ring : @IsSemiRing A Aplus Amult Azero Aone
+  { naturals_ring : @IsSemiCRing A Aplus Amult Azero Aone
   ; naturals_order : FullPseudoSemiRingOrder Ale Alt
-  ; naturals_to_semiring_mor : forall {B} `{IsSemiRing B},
+  ; naturals_to_semiring_mor : forall {B} `{IsSemiCRing B},
     IsSemiRingPreserving (naturals_to_semiring A B)
-  ; naturals_initial: forall {B} `{IsSemiRing B} {h : A -> B} `{!IsSemiRingPreserving h} x,
+  ; naturals_initial: forall {B} `{IsSemiCRing B} {h : A -> B} `{!IsSemiRingPreserving h} x,
     naturals_to_semiring A B x = h x }.
 #[export] Existing Instances naturals_ring naturals_order naturals_to_semiring_mor.
 
diff --git a/theories/Classes/interfaces/round.v b/theories/Classes/interfaces/round.v
index c1d4a5e0c80..289df2f52db 100644
--- a/theories/Classes/interfaces/round.v
+++ b/theories/Classes/interfaces/round.v
@@ -6,7 +6,7 @@ Require Import
 
 Section round_up.
 
-  Class RoundUpStrict A `{IsSemiRing A} `{StrictSemiRingOrder A}
+  Class RoundUpStrict A `{IsSemiCRing A} `{StrictSemiRingOrder A}
     := round_up_strict : forall a : A, {n : nat & a < naturals_to_semiring nat A n}.
   Global Arguments round_up_strict A {_ _ _ _ _ _ _ _ _ _ _ _} _.
 
diff --git a/theories/Classes/interfaces/ua_algebra.v b/theories/Classes/interfaces/ua_algebra.v
index 4ca840bc655..ff2cefdcb9e 100644
--- a/theories/Classes/interfaces/ua_algebra.v
+++ b/theories/Classes/interfaces/ua_algebra.v
@@ -9,7 +9,7 @@ Require Export
 Require Import
   HoTT.Types
   HoTT.HSet
-  HoTT.Classes.implementations.list.
+  HoTT.Spaces.List.Core.
 
 Import ne_list.notations.
 
diff --git a/theories/Classes/isomorphisms/rings.v b/theories/Classes/isomorphisms/rings.v
index 4e4d2768d83..568b2f7dca5 100644
--- a/theories/Classes/isomorphisms/rings.v
+++ b/theories/Classes/isomorphisms/rings.v
@@ -96,7 +96,7 @@ Context `{Funext} `{Univalence}.
 Context (A B : Operations@{U V}).
 
 (* NB: we need to know they're rings for preserves_negate *)
-Context (f : A -> B) `{!IsEquiv f} `{!IsRing A} `{!IsRing B} `{!IsSemiRingPreserving f}.
+Context (f : A -> B) `{!IsEquiv f} `{!IsCRing A} `{!IsCRing B} `{!IsSemiRingPreserving f}.
 
 Lemma iso_same_rings : A = B.
 Proof.
diff --git a/theories/Classes/orders/nat_int.v b/theories/Classes/orders/nat_int.v
index 51c04780320..d241077449c 100644
--- a/theories/Classes/orders/nat_int.v
+++ b/theories/Classes/orders/nat_int.v
@@ -21,7 +21,7 @@ the rationals or the reals), any morphism to it is an order embedding.
 *)
 Lemma to_semiring_nonneg `{FullPseudoSemiRingOrder N}
   `{!NaturalsToSemiRing N} `{!Naturals N} `{FullPseudoSemiRingOrder R}
-  `{!IsSemiRing R}
+  `{!IsSemiCRing R}
   `{!IsSemiRingPreserving (f : N -> R)} n : 0 ≤ f n.
 Proof.
 revert n. apply naturals.induction.
@@ -36,7 +36,7 @@ Qed.
 
 Section nat_int_order.
 Context `{Naturals N} `{Apart N} `{Le N} `{Lt N} `{!FullPseudoSemiRingOrder le lt}
-  `{FullPseudoSemiRingOrder R} `{!IsSemiRing R}
+  `{FullPseudoSemiRingOrder R} `{!IsSemiCRing R}
   `{!Biinduction R} `{PropHolds (1 ≶ 0)}.
 
 (* Add Ring R : (stdlib_semiring_theory R). *)
@@ -143,7 +143,7 @@ Lemma le_iff_lt_S x y : x ≤ y <-> x < 1 + y.
 Proof. rewrite plus_comm. apply le_iff_lt_plus_1. Qed.
 
 Section another_semiring.
-  Context `{FullPseudoSemiRingOrder R2} `{!IsSemiRing R2}
+  Context `{FullPseudoSemiRingOrder R2} `{!IsSemiCRing R2}
     `{PropHolds ((1 : R2) ≶ 0)}
     `{!IsSemiRingPreserving (f : R -> R2)}.
 
diff --git a/theories/Classes/orders/naturals.v b/theories/Classes/orders/naturals.v
index 01086fb7daf..768067c328d 100644
--- a/theories/Classes/orders/naturals.v
+++ b/theories/Classes/orders/naturals.v
@@ -77,7 +77,7 @@ as [E | E].
 Qed.
 
 Section another_ring.
-  Context `{IsRing R} `{Apart R} `{!FullPseudoSemiRingOrder (A:=R) Rle Rlt}
+  Context `{IsCRing R} `{Apart R} `{!FullPseudoSemiRingOrder (A:=R) Rle Rlt}
     `{!IsSemiRingPreserving (f : N -> R)}.
 
   Lemma negate_to_ring_nonpos n : -f n ≤ 0.
diff --git a/theories/Classes/orders/rings.v b/theories/Classes/orders/rings.v
index 28f6a1dd7c5..b6b01251fbf 100644
--- a/theories/Classes/orders/rings.v
+++ b/theories/Classes/orders/rings.v
@@ -9,7 +9,7 @@ Require Export
 Generalizable Variables R Rle Rlt R1le R1lt.
 
 Section from_ring_order.
-  Context `{IsRing R} `{!PartialOrder Rle}
+  Context `{IsCRing R} `{!PartialOrder Rle}
     (plus_spec : forall z, OrderPreserving (z +))
     (mult_spec : forall x y, PropHolds (0 ≤ x) -> PropHolds (0 ≤ y) ->
       PropHolds (0 ≤ x * y)).
@@ -28,7 +28,7 @@ Section from_ring_order.
 End from_ring_order.
 
 Section from_strict_ring_order.
-  Context `{IsRing R} `{!StrictOrder Rlt}
+  Context `{IsCRing R} `{!StrictOrder Rlt}
     (plus_spec : forall z, StrictlyOrderPreserving (z +))
     (mult_spec : forall x y, PropHolds (0 < x) -> PropHolds (0 < y) ->
       PropHolds (0 < x * y)).
@@ -47,7 +47,7 @@ Section from_strict_ring_order.
 End from_strict_ring_order.
 
 Section from_pseudo_ring_order.
-  Context `{IsRing R} `{Apart R} `{!PseudoOrder Rlt}
+  Context `{IsCRing R} `{Apart R} `{!PseudoOrder Rlt}
     (plus_spec : forall z, StrictlyOrderPreserving (z +))
     (mult_ext : StrongBinaryExtensionality (.*.))
     (mult_spec : forall x y, PropHolds (0 < x) -> PropHolds (0 < y) ->
@@ -68,7 +68,7 @@ Section from_pseudo_ring_order.
 End from_pseudo_ring_order.
 
 Section from_full_pseudo_ring_order.
-  Context `{IsRing R} `{Apart R} `{!FullPseudoOrder Rle Rlt}
+  Context `{IsCRing R} `{Apart R} `{!FullPseudoOrder Rle Rlt}
     (plus_spec : forall z, StrictlyOrderPreserving (z +))
     (mult_ext : StrongBinaryExtensionality (.*.))
     (mult_spec : forall x y, PropHolds (0 < x) -> PropHolds (0 < y) ->
@@ -84,7 +84,7 @@ Section from_full_pseudo_ring_order.
 End from_full_pseudo_ring_order.
 
 Section ring_order.
-  Context `{IsRing R} `{!SemiRingOrder Rle}.
+  Context `{IsCRing R} `{!SemiRingOrder Rle}.
 (*   Add Ring R : (stdlib_ring_theory R). *)
 
   Lemma flip_le_negate x y : -y ≤ -x <-> x ≤ y.
@@ -170,7 +170,7 @@ Section ring_order.
 End ring_order.
 
 Section strict_ring_order.
-  Context `{IsRing R} `{!StrictSemiRingOrder Rlt}.
+  Context `{IsCRing R} `{!StrictSemiRingOrder Rlt}.
 (*   Add Ring Rs : (stdlib_ring_theory R). *)
 
   Lemma flip_lt_negate x y : -y < -x <-> x < y.
@@ -282,7 +282,7 @@ Section strict_ring_apart.
 End strict_ring_apart.
 
 Section another_ring_order.
-  Context `{IsRing R1} `{!SemiRingOrder R1le} `{IsRing R2} `{R2le : Le R2}
+  Context `{IsCRing R1} `{!SemiRingOrder R1le} `{IsCRing R2} `{R2le : Le R2}
     `{is_mere_relation R2 R2le}.
 
   Lemma projected_ring_order (f : R2 -> R1) `{!IsSemiRingPreserving f} `{!IsInjective f}
@@ -317,7 +317,7 @@ Section another_ring_order.
 End another_ring_order.
 
 Section another_strict_ring_order.
-  Context `{IsRing R1} `{!StrictSemiRingOrder R1lt} `{IsRing R2} `{R2lt : Lt R2}
+  Context `{IsCRing R1} `{!StrictSemiRingOrder R1lt} `{IsCRing R2} `{R2lt : Lt R2}
     `{is_mere_relation R2 lt}.
 
   Lemma projected_strict_ring_order (f : R2 -> R1) `{!IsSemiRingPreserving f} :
@@ -335,8 +335,8 @@ Section another_strict_ring_order.
 End another_strict_ring_order.
 
 Section another_pseudo_ring_order.
-  Context `{IsRing R1} `{Apart R1} `{!PseudoSemiRingOrder R1lt}
-    `{IsRing R2} `{IsApart R2} `{R2lt : Lt R2}
+  Context `{IsCRing R1} `{Apart R1} `{!PseudoSemiRingOrder R1lt}
+    `{IsCRing R2} `{IsApart R2} `{R2lt : Lt R2}
     `{is_mere_relation R2 lt}.
 
   Lemma projected_pseudo_ring_order (f : R2 -> R1) `{!IsSemiRingPreserving f}
@@ -360,8 +360,8 @@ Section another_pseudo_ring_order.
 End another_pseudo_ring_order.
 
 Section another_full_pseudo_ring_order.
-  Context `{IsRing R1} `{Apart R1} `{!FullPseudoSemiRingOrder R1le R1lt}
-    `{IsRing R2} `{IsApart R2} `{R2le : Le R2} `{R2lt : Lt R2}
+  Context `{IsCRing R1} `{Apart R1} `{!FullPseudoSemiRingOrder R1le R1lt}
+    `{IsCRing R2} `{IsApart R2} `{R2le : Le R2} `{R2lt : Lt R2}
     `{is_mere_relation R2 le} `{is_mere_relation R2 lt}.
 
   Lemma projected_full_pseudo_ring_order (f : R2 -> R1) `{!IsSemiRingPreserving f}
diff --git a/theories/Classes/orders/semirings.v b/theories/Classes/orders/semirings.v
index 5281d8021f9..91ae7a209b8 100644
--- a/theories/Classes/orders/semirings.v
+++ b/theories/Classes/orders/semirings.v
@@ -10,7 +10,7 @@ Require Export
 Generalizable Variables R Rlt f.
 
 Section semiring_order.
-  Context `{SemiRingOrder R} `{!IsSemiRing R}.
+  Context `{SemiRingOrder R} `{!IsSemiCRing R}.
 (*   Add Ring R : (stdlib_semiring_theory R). *)
 
   Global Instance plus_le_embed_l : forall (z : R), OrderEmbedding (+z).
@@ -186,7 +186,7 @@ Hint Extern 7 (PropHolds (0 ≤ _ + _)) =>
   eapply @nonneg_plus_compat : typeclass_instances.
 
 Section strict_semiring_order.
-  Context `{IsSemiRing R} `{!StrictSemiRingOrder Rlt}.
+  Context `{IsSemiCRing R} `{!StrictSemiRingOrder Rlt}.
 (*   Add Ring Rs : (stdlib_semiring_theory R). *)
 
   Global Instance plus_lt_embed : forall (z : R), StrictOrderEmbedding (+z).
@@ -350,7 +350,7 @@ Hint Extern 7 (PropHolds (0 < _ + _)) =>
   eapply @pos_plus_compat : typeclass_instances.
 
 Section pseudo_semiring_order.
-  Context `{PseudoSemiRingOrder R} `{!IsSemiRing R}.
+  Context `{PseudoSemiRingOrder R} `{!IsSemiCRing R}.
 (*   Add Ring Rp : (stdlib_semiring_theory R). *)
 
   Local Existing Instance pseudo_order_apart.
@@ -570,7 +570,7 @@ Hint Extern 7 (PropHolds (0 < 4)) => eapply @lt_0_4 : typeclass_instances.
 Hint Extern 7 (PropHolds (2 ≶ 0)) => eapply @apart_0_2 : typeclass_instances.
 
 Section full_pseudo_semiring_order.
-  Context `{FullPseudoSemiRingOrder R} `{!IsSemiRing R}.
+  Context `{FullPseudoSemiRingOrder R} `{!IsSemiCRing R}.
 
 (*   Add Ring Rf : (stdlib_semiring_theory R). *)
 
@@ -848,7 +848,7 @@ End dec_semiring_order.
 Section another_semiring.
   Context `{SemiRingOrder R1}.
 
-  Lemma projected_srorder `{IsSemiRing R2} `{R2le : Le R2}
+  Lemma projected_srorder `{IsSemiCRing R2} `{R2le : Le R2}
     `{is_mere_relation R2 R2le} (f : R2 -> R1)
     `{!IsSemiRingPreserving f} `{!IsInjective f}
     : (forall x y, x ≤ y <-> f x ≤ f y) -> (forall x y : R2, x ≤ y -> exists z, y = x + z) ->
@@ -865,7 +865,7 @@ Section another_semiring.
     apply nonneg_mult_compat; rewrite <-(preserves_0 (f:=f)); apply P;trivial.
   Qed.
 
- Context `{!IsSemiRing R1} `{SemiRingOrder R2} `{!IsSemiRing R2}
+ Context `{!IsSemiCRing R1} `{SemiRingOrder R2} `{!IsSemiCRing R2}
    `{!IsSemiRingPreserving (f : R1 -> R2)}.
 
   (* If a morphism agrees on the positive cone then it is order preserving *)
@@ -904,7 +904,7 @@ End another_semiring.
 
 Section another_semiring_strict.
   Context `{StrictSemiRingOrder R1} `{StrictSemiRingOrder R2}
-    `{!IsSemiRing R1} `{!IsSemiRing R2}
+    `{!IsSemiCRing R1} `{!IsSemiCRing R2}
     `{!IsSemiRingPreserving (f : R1 -> R2)}.
 
   Lemma strictly_preserving_preserves_pos
diff --git a/theories/Classes/tactics/ring_quote.v b/theories/Classes/tactics/ring_quote.v
index 01d7b00a4f8..d18bd798900 100644
--- a/theories/Classes/tactics/ring_quote.v
+++ b/theories/Classes/tactics/ring_quote.v
@@ -5,7 +5,7 @@ Class AlmostNegate A := almost_negate : A -> A.
 
 Class AlmostRing A {Aplus : Plus A} {Amult : Mult A}
   {Azero : Zero A} {Aone : One A} {Anegate : AlmostNegate A} :=
-  { almost_ring_semiring : IsSemiRing A
+  { almost_ring_semiring : IsSemiCRing A
   ; almost_ring_neg_pr : forall x : A, almost_negate x = (almost_negate 1) * x }.
 
 Section almostring_mor.
diff --git a/theories/Classes/tactics/ring_tac.v b/theories/Classes/tactics/ring_tac.v
index a1ac66bc0b1..577d9a35f12 100644
--- a/theories/Classes/tactics/ring_tac.v
+++ b/theories/Classes/tactics/ring_tac.v
@@ -68,18 +68,18 @@ Global Instance negate_almostneg `{Aneg : Negate A} : AlmostNegate A
   := (-).
 Arguments negate_almostneg _ _ _ /.
 
-Global Instance semiring_almostring `{IsSemiRing A} : AlmostRing A | 10.
+Global Instance semiring_almostring `{IsSemiCRing A} : AlmostRing A | 10.
 Proof.
 split;try apply _.
 intros. unfold almost_negate;simpl.
 symmetry;apply mult_0_l.
 Qed.
 
-Global Instance ring_almostring `{IsRing A} : AlmostRing A.
+Global Instance ring_almostring `{IsCRing A} : AlmostRing A.
 Proof.
 split;try apply _.
 intros. unfold almost_negate;simpl.
-apply negate_mult.
+apply negate_mult_l.
 Qed.
 
 Global Instance sr_mor_almostring_mor `{IsSemiRingPreserving A B f}
@@ -90,7 +90,7 @@ unfold almost_negate;simpl. intros _. apply preserves_0.
 Qed.
 
 Section VarSec.
-Context `{IsRing A} `{IsRing B} {f : A -> B} `{!IsSemiRingPreserving f}.
+Context `{IsCRing A} `{IsCRing B} {f : A -> B} `{!IsSemiRingPreserving f}.
 
 Global Instance ring_mor_almostring_mor : AlmostRingPreserving f.
 Proof.
@@ -108,7 +108,7 @@ Arguments by_quoting {C _ R} phi
 Ltac ring_with_nat :=
   match goal with
   |- @paths ?R _ _ =>
-    ((pose proof (_ : IsSemiRing R)) || fail "target equality not on a semiring");
+    ((pose proof (_ : IsSemiCRing R)) || fail "target equality not on a semiring");
     apply (by_quoting (naturals_to_semiring nat R));
     reflexivity
   end.
@@ -116,7 +116,7 @@ Ltac ring_with_nat :=
 Ltac ring_with_integers Z :=
   match goal with
   |- @paths ?R _ _ =>
-    ((pose proof (_ : IsRing R)) || fail "target equality not on a ring");
+    ((pose proof (_ : IsCRing R)) || fail "target equality not on a ring");
     apply (by_quoting (integers_to_ring Z R));
     reflexivity
   end.
@@ -124,7 +124,7 @@ Ltac ring_with_integers Z :=
 Ltac ring_with_self :=
   match goal with
   |- @paths ?R _ _ =>
-    ((pose proof (_ : IsSemiRing R)) || fail "target equality not on a ring");
+    ((pose proof (_ : IsSemiCRing R)) || fail "target equality not on a ring");
     apply (by_quoting (@id R));
     reflexivity
   end.
diff --git a/theories/Classes/theory/additional_operations.v b/theories/Classes/theory/additional_operations.v
index 69857a5311b..bb6ae2b264b 100644
--- a/theories/Classes/theory/additional_operations.v
+++ b/theories/Classes/theory/additional_operations.v
@@ -1,4 +1,4 @@
-Require Import HoTT.Classes.interfaces.abstract_algebra.
+Require Import HoTT.Classes.interfaces.canonical_names.
 
 Generalizable Variables A R.
 
diff --git a/theories/Classes/theory/groups.v b/theories/Classes/theory/groups.v
index 0015c13ae63..b1edde9d578 100644
--- a/theories/Classes/theory/groups.v
+++ b/theories/Classes/theory/groups.v
@@ -40,13 +40,15 @@ Section group_props.
   Global Instance group_cancelL : forall z : G, LeftCancellation (.*.) z.
   Proof.
     intros z x y E.
-    rewrite <- (left_identity x).
-    rewrite <- (left_inverse (unit:=mon_unit) z).
-    rewrite <- simple_associativity.
-    rewrite E.
-    rewrite simple_associativity, (left_inverse z), left_identity.
-    reflexivity.
-  Qed.
+    rhs_V rapply left_identity.
+    rhs_V rapply (ap (.* y) (left_inverse z)).
+    rhs_V rapply simple_associativity.
+    rhs_V rapply (ap (-z *.) E).
+    symmetry.
+    lhs rapply simple_associativity.
+    lhs rapply (ap (.* x) (left_inverse z)).
+    apply left_identity.
+  Defined.
 
   Global Instance group_cancelR: forall z : G, RightCancellation (.*.) z.
   Proof.
@@ -225,106 +227,3 @@ Section from_another_ab_group.
   Qed.
 
 End from_another_ab_group.
-
-Section id_mor.
-
-  Context `{SgOp A} `{MonUnit A}.
-
-  Global Instance id_sg_morphism : IsSemiGroupPreserving (@id A).
-  Proof.
-    split.
-  Defined.
-
-  Global Instance id_monoid_morphism : IsMonoidPreserving (@id A).
-  Proof.
-    split; split.
-  Defined.
-
-End id_mor.
-
-Section compose_mor.
-
-  Context
-    `{SgOp A} `{MonUnit A}
-    `{SgOp B} `{MonUnit B}
-    `{SgOp C} `{MonUnit C}
-    (f : A -> B) (g : B -> C).
-
-  (** Making these global instances causes typeclass loops.  Instead they are declared below as [Hint Extern]s that apply only when the goal has the specified form. *)
-  Local Instance compose_sg_morphism : IsSemiGroupPreserving f -> IsSemiGroupPreserving g ->
-    IsSemiGroupPreserving (g ∘ f).
-  Proof.
-    red; intros fp gp x y.
-    unfold Compose.
-    refine ((ap g _) @ _).
-    - apply fp.
-    - apply gp.
-  Defined.
-
-  Local Instance compose_monoid_morphism : IsMonoidPreserving f -> IsMonoidPreserving g ->
-    IsMonoidPreserving (g ∘ f).
-  Proof.
-    intros;split.
-    - apply _.
-    - red;unfold Compose.
-      etransitivity;[|apply (preserves_mon_unit (f:=g))].
-      apply ap,preserves_mon_unit.
-  Defined.
-
-End compose_mor.
-
-Section invert_mor.
-
-  Context
-    `{SgOp A} `{MonUnit A}
-    `{SgOp B} `{MonUnit B}
-    (f : A -> B).
-
-  Local Instance invert_sg_morphism
-    : forall `{!IsEquiv f}, IsSemiGroupPreserving f ->
-      IsSemiGroupPreserving (f^-1).
-  Proof.
-    red; intros E fp x y.
-    apply (equiv_inj f).
-    refine (_ @ _ @ _ @ _)^.
-    - apply fp.
-    (* We could use [apply ap2; apply eisretr] here, but it is convenient
-       to have things in terms of ap. *)
-    - refine (ap (fun z => z * _) _); apply eisretr.
-    - refine (ap (fun z => _ * z) _); apply eisretr.
-    - symmetry; apply eisretr.
-  Defined.
-
-  Local Instance invert_monoid_morphism :
-    forall `{!IsEquiv f}, IsMonoidPreserving f -> IsMonoidPreserving (f^-1).
-  Proof.
-    intros;split.
-    - apply _.
-    - apply (equiv_inj f).
-      refine (_ @ _).
-      + apply eisretr.
-      + symmetry; apply preserves_mon_unit.
-  Defined.
-
-End invert_mor.
-
-#[export]
-Hint Extern 4 (IsSemiGroupPreserving (_ ∘ _)) =>
-  class_apply @compose_sg_morphism : typeclass_instances.
-#[export]
-Hint Extern 4 (IsMonoidPreserving (_ ∘ _)) =>
-  class_apply @compose_monoid_morphism : typeclass_instances.
-
-#[export]
-Hint Extern 4 (IsSemiGroupPreserving (_ o _)) =>
-  class_apply @compose_sg_morphism : typeclass_instances.
-#[export]
-Hint Extern 4 (IsMonoidPreserving (_ o _)) =>
-  class_apply @compose_monoid_morphism : typeclass_instances.
-
-#[export]
-Hint Extern 4 (IsSemiGroupPreserving (_^-1)) =>
-  class_apply @invert_sg_morphism : typeclass_instances.
-#[export]
-Hint Extern 4 (IsMonoidPreserving (_^-1)) =>
-  class_apply @invert_monoid_morphism : typeclass_instances.
diff --git a/theories/Classes/theory/integers.v b/theories/Classes/theory/integers.v
index 4d173c4fe4e..c853c8fafe4 100644
--- a/theories/Classes/theory/integers.v
+++ b/theories/Classes/theory/integers.v
@@ -15,14 +15,14 @@ Require Export
 Import NatPair.Instances.
 Generalizable Variables N Z R f.
 
-Lemma to_ring_unique `{Integers Z} `{IsRing R} (f: Z -> R)
+Lemma to_ring_unique `{Integers Z} `{IsCRing R} (f: Z -> R)
   {h: IsSemiRingPreserving f} x
   : f x = integers_to_ring Z R x.
 Proof.
 symmetry. apply integers_initial.
 Qed.
 
-Lemma to_ring_unique_alt `{Integers Z} `{IsRing R} (f g: Z -> R)
+Lemma to_ring_unique_alt `{Integers Z} `{IsCRing R} (f g: Z -> R)
   `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x :
   f x = g x.
 Proof.
@@ -36,11 +36,11 @@ change (Compose (integers_to_ring Z2 Z) (integers_to_ring Z Z2) x = id x).
 apply to_ring_unique_alt;apply _.
 Qed.
 
-Lemma morphisms_involutive `{Integers Z} `{IsRing R} (f: R -> Z) (g: Z -> R)
+Lemma morphisms_involutive `{Integers Z} `{IsCRing R} (f: R -> Z) (g: Z -> R)
   `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x : f (g x) = x.
 Proof. exact (to_ring_unique_alt (f ∘ g) id _). Qed.
 
-Lemma to_ring_twice `{Integers Z} `{IsRing R1} `{IsRing R2}
+Lemma to_ring_twice `{Integers Z} `{IsCRing R1} `{IsCRing R2}
   (f : R1 -> R2) (g : Z -> R1) (h : Z -> R2)
   `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} `{!IsSemiRingPreserving h} x
   : f (g x) = h x.
@@ -51,7 +51,7 @@ Proof. exact (to_ring_unique_alt f id _). Qed.
 
 (* A ring morphism from integers to another ring is injective
    if there's an injection in the other direction: *)
-Lemma to_ring_injective `{Integers Z} `{IsRing R} (f: R -> Z) (g: Z -> R)
+Lemma to_ring_injective `{Integers Z} `{IsCRing R} (f: R -> Z) (g: Z -> R)
   `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g}
   : IsInjective g.
 Proof.
@@ -80,7 +80,7 @@ Qed.
 
 Section retract_is_int.
   Context `{Funext}.
-  Context `{Integers Z} `{IsRing Z2}
+  Context `{Integers Z} `{IsCRing Z2}
     {Z2ap : Apart Z2} {Z2le Z2lt} `{!FullPseudoSemiRingOrder (A:=Z2) Z2le Z2lt}.
   Context (f : Z -> Z2) `{!IsEquiv f} `{!IsSemiRingPreserving f}
     `{!IsSemiRingPreserving (f^-1)}.
@@ -90,7 +90,7 @@ Section retract_is_int.
     integers_to_ring Z Z2 ∘ f^-1.
 
   Section for_another_ring.
-    Context `{IsRing R}.
+    Context `{IsCRing R}.
 
     Instance: IsSemiRingPreserving (integers_to_ring Z R ∘ f^-1) := {}.
     Context (h :  Z2 -> R) `{!IsSemiRingPreserving h}.
diff --git a/theories/Classes/theory/naturals.v b/theories/Classes/theory/naturals.v
index e3811f93263..7b552c3a609 100644
--- a/theories/Classes/theory/naturals.v
+++ b/theories/Classes/theory/naturals.v
@@ -13,14 +13,14 @@ Generalizable Variables A N R SR f.
 (* This grabs a coercion. *)
 Import SemiRings.
 
-Lemma to_semiring_unique `{Naturals N} `{IsSemiRing SR} (f: N -> SR)
+Lemma to_semiring_unique `{Naturals N} `{IsSemiCRing SR} (f: N -> SR)
   `{!IsSemiRingPreserving f} x
   : f x = naturals_to_semiring N SR x.
 Proof.
 symmetry. apply naturals_initial.
 Qed.
 
-Lemma to_semiring_unique_alt `{Naturals N} `{IsSemiRing SR} (f g: N -> SR)
+Lemma to_semiring_unique_alt `{Naturals N} `{IsSemiCRing SR} (f g: N -> SR)
   `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x
   : f x = g x.
 Proof.
@@ -34,11 +34,11 @@ change (Compose (naturals_to_semiring N2 N) (naturals_to_semiring N N2) x = id x
 apply to_semiring_unique_alt;apply _.
 Qed.
 
-Lemma morphisms_involutive `{Naturals N} `{IsSemiRing R} (f : R -> N) (g : N -> R)
+Lemma morphisms_involutive `{Naturals N} `{IsSemiCRing R} (f : R -> N) (g : N -> R)
   `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} x : f (g x) = x.
 Proof. exact (to_semiring_unique_alt (f ∘ g) id _). Qed.
 
-Lemma to_semiring_twice `{Naturals N} `{IsSemiRing R1} `{IsSemiRing R2}
+Lemma to_semiring_twice `{Naturals N} `{IsSemiCRing R1} `{IsSemiCRing R2}
   (f : R1 -> R2) (g : N -> R1) (h : N -> R2)
   `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g} `{!IsSemiRingPreserving h} x
   : f (g x) = h x.
@@ -48,7 +48,7 @@ Lemma to_semiring_self `{Naturals N} (f : N -> N) `{!IsSemiRingPreserving f} x
   : f x = x.
 Proof. exact (to_semiring_unique_alt f id _). Qed.
 
-Lemma to_semiring_injective `{Naturals N} `{IsSemiRing A}
+Lemma to_semiring_injective `{Naturals N} `{IsSemiCRing A}
    (f: A -> N) (g: N -> A) `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving g}
    : IsInjective g.
 Proof.
@@ -64,7 +64,7 @@ Global Instance naturals_to_naturals_injective `{Naturals N} `{Naturals N2}
 Proof. exact (to_semiring_injective (naturals_to_semiring N2 N) _). Qed.
 
 Section retract_is_nat.
-  Context `{Naturals N} `{IsSemiRing SR}
+  Context `{Naturals N} `{IsSemiCRing SR}
     {SRap : Apart SR} {SRle SRlt} `{!FullPseudoSemiRingOrder (A:=SR) SRle SRlt}.
   Context (f : N -> SR) `{!IsEquiv f}
     `{!IsSemiRingPreserving f} `{!IsSemiRingPreserving (f^-1)}.
@@ -74,7 +74,7 @@ Section retract_is_nat.
     := fun R _ _ _ _ _ => naturals_to_semiring N R ∘ f^-1.
 
   Section for_another_semirings.
-    Context `{IsSemiRing R}.
+    Context `{IsSemiCRing R}.
 
     Instance: IsSemiRingPreserving (naturals_to_semiring N R ∘ f^-1) := {}.
 
@@ -220,7 +220,7 @@ apply decidablepaths_equiv with nat (naturals_to_semiring nat N);apply _.
 Qed.
 
 Section with_a_ring.
-  Context `{IsRing R} `{!IsSemiRingPreserving (f : N -> R)} `{!IsInjective f}.
+  Context `{IsCRing R} `{!IsSemiRingPreserving (f : N -> R)} `{!IsInjective f}.
 
   Lemma to_ring_zero_sum x y :
     -f x = f y -> x = 0 /\ y = 0.
diff --git a/theories/Classes/theory/premetric.v b/theories/Classes/theory/premetric.v
index 06ec0fccf93..4674d0976cc 100644
--- a/theories/Classes/theory/premetric.v
+++ b/theories/Classes/theory/premetric.v
@@ -21,7 +21,6 @@ Generalizable Variables A B.
 
 Local Set Universe Minimization ToSet.
 
-
 Class Closeness@{i} (A : Type@{i}) := close : Q+ -> Relation@{i i} A.
 
 Global Instance Q_close@{} : Closeness Q := fun e q r => - ' e < q - r < ' e.
@@ -299,8 +298,7 @@ Class Continuous@{UA UB}
 Arguments continuous {A _ B _} f {_} _ _.
 
 Definition BinaryDup@{i} {A : Type@{i} } : A -> A /\ A := fun x => (x, x).
-Definition uncurry {A B C} (f : A -> B -> C) : A /\ B -> C
-  := fun x => f (fst x) (snd x).
+
 Definition map2 {A B C D} (f : A -> C) (g : B -> D) : A /\ B -> C /\ D
   := fun x => (f (fst x), g (snd x)).
 
@@ -464,7 +462,7 @@ Global Instance uncurry_lipschitz (f : A -> B -> C) L1 L2
   : Lipschitz (uncurry f) (L1 + L2).
 Proof.
 intros e [u1 u2] [v1 v2] [xi1 xi2]. simpl in xi1,xi2.
-unfold uncurry;simpl.
+simpl.
 assert (Hrw : (L1 + L2) * e = L1 * e + L2 * e)
 by abstract (apply pos_eq;ring_tac.ring_with_nat);
 rewrite Hrw;clear Hrw.
diff --git a/theories/Classes/theory/rings.v b/theories/Classes/theory/rings.v
index 241238be036..17f0835fe4a 100644
--- a/theories/Classes/theory/rings.v
+++ b/theories/Classes/theory/rings.v
@@ -74,7 +74,7 @@ Section strong_cancellation.
 End strong_cancellation.
 
 Section semiring_props.
-  Context `{IsSemiRing R}.
+  Context `{IsSemiCRing R}.
 (*   Add Ring SR : (stdlib_semiring_theory R). *)
 
   Instance mult_ne_0 `{!NoZeroDivisors R} x y
@@ -167,14 +167,14 @@ Section semiringmor_props.
   Context `{!IsInjective f}.
   Instance isinjective_ne_0 x : PropHolds (x <> 0) -> PropHolds (f x <> 0).
   Proof.
-  intros. rewrite <-preserves_0. apply (isinjective_ne f).
+  intros. rewrite <-preserves_0. apply (neq_isinj f).
   assumption.
   Qed.
 
   Lemma injective_ne_1 x : x <> 1 -> f x <> 1.
   Proof.
   intros. rewrite <-preserves_1.
-  apply (isinjective_ne f).
+  apply (neq_isinj f).
   assumption.
   Qed.
 End semiringmor_props.
@@ -189,12 +189,9 @@ Hint Extern 12 (PropHolds (_ _ <> 0)) =>
 Proof.
 Qed.
 *)
-
-Section ring_props.
-  Context `{IsRing R}.
-
-(*   Add Ring R: (stdlib_ring_theory R). *)
-
+Section cring_props.
+  Context `{IsCRing R}.
+  
   Instance: LeftAbsorb (.*.) 0.
   Proof.
   intro.
@@ -206,11 +203,37 @@ Section ring_props.
   - apply ap. apply right_identity.
   Qed.
 
-  Global Instance Ring_Semi: IsSemiRing R.
+  Global Instance CRing_Semi: IsSemiCRing R.
   Proof.
   repeat (constructor; try apply _).
   Qed.
 
+End cring_props.
+
+
+Section ring_props.
+  Context `{IsRing R}.
+
+  Global Instance mult_left_absorb : LeftAbsorb (.*.) 0.
+  Proof.
+    intro y.
+    rapply (right_cancellation (+) (0 * y)).
+    lhs_V rapply simple_distribute_r.
+    rhs rapply left_identity.
+    nrapply (ap (.* y)).
+    apply left_identity.
+  Defined.
+
+  Global Instance mult_right_absorb : RightAbsorb (.*.) 0.
+  Proof.
+    intro x.
+    rapply (right_cancellation (+) (x * 0)).
+    lhs_V rapply simple_distribute_l.
+    rhs rapply left_identity.
+    nrapply (ap (x *.)).
+    apply left_identity.
+  Defined.
+
   Definition negate_involutive x : - - x = x := groups.negate_involutive x.
   (* alias for convenience *)
 
@@ -236,7 +259,7 @@ Section ring_props.
   Lemma negate_plus_distr : forall x y, -(x + y) = -x + -y.
   Proof. exact groups.negate_sg_op_distr. Qed.
 
-  Lemma negate_mult x : -x = - 1 * x.
+  Lemma negate_mult_l x : -x = - 1 * x.
   Proof.
   apply (left_cancellation (+) x).
   path_via 0.
@@ -249,18 +272,37 @@ Section ring_props.
       apply left_identity.
   Qed.
 
+  Lemma negate_mult_r x : -x = x * -1.
+  Proof.
+    apply (right_cancellation (+) x).
+    transitivity (x * -1 + x * 1).
+    - lhs apply left_inverse.
+      rhs_V rapply simple_distribute_l.
+      lhs_V rapply (right_absorb x).
+      apply (ap (x *.)).
+      symmetry.
+      apply left_inverse.
+    - f_ap.
+      apply right_identity.
+  Defined.
+
   Lemma negate_mult_distr_l x y : -(x * y) = -x * y.
   Proof.
-  rewrite negate_mult,(negate_mult x).
-  apply associativity.
-  Qed.
+    lhs nrapply negate_mult_l.
+    lhs rapply (simple_associativity (f := (.*.)) (-1) x y).
+    apply (ap (.* y)).
+    symmetry.
+    apply negate_mult_l.
+  Defined.
 
   Lemma negate_mult_distr_r x y : -(x * y) = x * -y.
   Proof.
-  rewrite negate_mult,(negate_mult y).
-  rewrite simple_associativity,(commutativity (- 1)).
-  apply symmetry,associativity.
-  Qed.
+    lhs nrapply negate_mult_r.
+    lhs_V rapply (simple_associativity (f := (.*.)) x y).
+    apply (ap (x *.)).
+    symmetry.
+    apply negate_mult_r.
+  Defined.
 
   Lemma negate_mult_negate x y : -x * -y = x * y.
   Proof.
@@ -273,13 +315,15 @@ Section ring_props.
 
   Global Instance minus_0_r: RightIdentity (fun x y => x - y) 0.
   Proof.
-  intro x; rewrite negate_0; apply plus_0_r.
+  intro x; rewrite negate_0. apply right_identity.
   Qed.
 
   Lemma equal_by_zero_sum x y : x - y = 0 <-> x = y.
   Proof.
   split; intros E.
-  - rewrite <- (plus_0_l y). rewrite <- E.
+  - rewrite <- (left_identity y).
+    change (sg_op ?x ?y) with (0 + y).
+    rewrite <- E.
     rewrite <-simple_associativity.
     rewrite left_inverse.
     apply symmetry,right_identity.
@@ -318,9 +362,18 @@ Section ring_props.
 
   Lemma negate_zero_prod_r x y : x * -y = 0 <-> x * y = 0.
   Proof.
-  rewrite (commutativity (f:=(.*.)) x (-y)), (commutativity (f:=(.*.)) x y).
-  apply negate_zero_prod_l.
-  Qed.
+    etransitivity.
+    2: apply negate_zero_prod_l.
+    split.
+    - intros E.
+      lhs_V nrapply negate_mult_distr_l. 
+      lhs nrapply negate_mult_distr_r.
+      exact E.
+    - intros E.
+      lhs_V nrapply negate_mult_distr_r.
+      lhs nrapply negate_mult_distr_l.
+      exact E.
+  Defined.
 
   Context `{!NoZeroDivisors R} `{forall x y:R, Stable (x = y)}.
 
@@ -334,26 +387,46 @@ Section ring_props.
   - intro. apply U. apply equal_by_zero_sum. trivial.
   - rewrite distribute_l, E.
     rewrite <-simple_distribute_l,right_inverse.
-    apply mult_0_r.
+    apply right_absorb.
   Qed.
 
-  Global Instance mult_right_cancel: forall z, PropHolds (z <> 0) ->
-    RightCancellation (.*.) z.
+  Instance mult_ne_0' `{!NoZeroDivisors R} x y
+    : PropHolds (x <> 0) -> PropHolds (y <> 0) -> PropHolds (x * y <> 0).
   Proof.
-  intros ? ?.
-  apply (right_cancel_from_left (.*.)).
+  intros Ex Ey Exy.
+  unfold PropHolds in *.
+  apply (no_zero_divisors x); split; eauto.
   Qed.
 
+  Global Instance mult_right_cancel : forall z, PropHolds (z <> 0) ->
+    RightCancellation (.*.) z.
+  Proof.
+    intros z ? x y p.
+    apply stable.
+    intro U.
+    nrapply (mult_ne_0' (x - y) z).
+    - exact _.
+    - intros r.
+      apply U, equal_by_zero_sum, r.
+    - exact _.
+    - lhs rapply ring_dist_right.
+      rewrite <- negate_mult_distr_l.
+      apply equal_by_zero_sum in p.
+      exact p.
+  Defined.
+
   Lemma plus_conjugate x y : x = y + x - y.
   Proof.
-  rewrite plus_comm, plus_assoc, plus_negate_l, plus_0_l.
-  reflexivity.
+    rewrite (commutativity (f := (+)) y x),
+      <- (simple_associativity (f := (+)) x y (-y)),
+      right_inverse, right_identity.
+    reflexivity.
   Qed.
 
   Lemma plus_conjugate_alt x y : x = y + (x - y).
   Proof.
-  rewrite plus_comm, <-plus_assoc, plus_negate_l, plus_0_r.
-  reflexivity.
+    rewrite (simple_associativity (f := (+))).
+    apply plus_conjugate.
   Qed.
 End ring_props.
 
@@ -390,19 +463,19 @@ Section ringmor_props.
   apply equal_by_zero_sum.
   apply E1.
   rewrite preserves_minus, E.
-  apply plus_negate_r.
+  apply right_inverse.
   Qed.
 End ringmor_props.
 
 Section from_another_ring.
-  Context `{IsRing A} `{IsHSet B}
+  Context `{IsCRing A} `{IsHSet B}
    `{Bplus : Plus B} `{Zero B} `{Bmult : Mult B} `{One B} `{Bnegate : Negate B}
     (f : B -> A) `{!IsInjective f}
     (plus_correct : forall x y, f (x + y) = f x + f y) (zero_correct : f 0 = 0)
     (mult_correct : forall x y, f (x * y) = f x * f y) (one_correct : f 1 = 1)
     (negate_correct : forall x, f (-x) = -f x).
 
-  Lemma projected_ring: IsRing B.
+  Lemma projected_ring: IsCRing B.
   Proof.
   split.
   - apply (groups.projected_ab_group f);assumption.
@@ -448,7 +521,7 @@ Section from_stdlib_ring_theory.
   Qed.
 End from_stdlib_ring_theory. *)
 
-Global Instance id_sr_morphism `{IsSemiRing A}: IsSemiRingPreserving (@id A) := {}.
+Global Instance id_sr_morphism `{IsSemiCRing A}: IsSemiRingPreserving (@id A) := {}.
 
 Section morphism_composition.
   Context `{Mult A} `{Plus A} `{One A} `{Zero A}
diff --git a/theories/Classes/theory/ua_first_isomorphism.v b/theories/Classes/theory/ua_first_isomorphism.v
index e1ecd7526a6..ed932090afe 100644
--- a/theories/Classes/theory/ua_first_isomorphism.v
+++ b/theories/Classes/theory/ua_first_isomorphism.v
@@ -4,9 +4,9 @@
     identification theorem [id_first_isomorphism] follows. *)
 
 Require Import
+  Basics.Notations
   HSet
   Colimits.Quotient
-  Modalities.ReflectiveSubuniverse
   Classes.interfaces.canonical_names
   Classes.theory.ua_isomorphic
   Classes.theory.ua_subalgebra
@@ -247,7 +247,7 @@ End first_isomorphism_surjection.
 Section first_isomorphism_inj.
   Context
     `{Univalence} {σ} {A B : Algebra σ} `{IsHSetAlgebra B}
-    (f : ∀ s, A s → B s) `{!IsHomomorphism f} (inj : ∀ s, isinj (f s)).
+    (f : ∀ s, A s → B s) `{!IsHomomorphism f} (inj : ∀ s, IsInjective (f s)).
 
   Global Instance is_isomorphism_quotient_first_isomorphism_inj
     : IsIsomorphism (hom_quotient (cong_ker f)).
diff --git a/theories/Classes/theory/ua_prod_algebra.v b/theories/Classes/theory/ua_prod_algebra.v
index cd3cae13edf..275a2656f0d 100644
--- a/theories/Classes/theory/ua_prod_algebra.v
+++ b/theories/Classes/theory/ua_prod_algebra.v
@@ -1,6 +1,5 @@
 Require Import
   HoTT.Types.Bool
-  HoTT.Types.Forall
   HoTT.Classes.theory.ua_homomorphism.
 
 Import algebra_notations ne_list.notations.
diff --git a/theories/Classes/theory/ua_quotient_algebra.v b/theories/Classes/theory/ua_quotient_algebra.v
index 978f81d6b81..d5b364472aa 100644
--- a/theories/Classes/theory/ua_quotient_algebra.v
+++ b/theories/Classes/theory/ua_quotient_algebra.v
@@ -1,12 +1,14 @@
+Require Import Basics.Notations.
 Require Export HoTT.Classes.interfaces.ua_congruence.
 
 Require Import
   HSet
   Colimits.Quotient
-  Classes.implementations.list
+  Spaces.List.Core
   Classes.interfaces.canonical_names
   Classes.theory.ua_homomorphism.
 
+Local Open Scope list_scope.
 Import algebra_notations ne_list.notations.
 
 Section quotient_algebra.
diff --git a/theories/Classes/theory/ua_second_isomorphism.v b/theories/Classes/theory/ua_second_isomorphism.v
index 42f57a6fda5..e3bf27054fc 100644
--- a/theories/Classes/theory/ua_second_isomorphism.v
+++ b/theories/Classes/theory/ua_second_isomorphism.v
@@ -1,6 +1,7 @@
 (** The second isomorphism theorem [isomorphic_second_isomorphism]. *)
 
 Require Import
+  Basics.Notations
   HSet
   Colimits.Quotient
   Classes.interfaces.canonical_names
diff --git a/theories/Classes/theory/ua_third_isomorphism.v b/theories/Classes/theory/ua_third_isomorphism.v
index ee6f2ac666d..2dcfc3a57f0 100644
--- a/theories/Classes/theory/ua_third_isomorphism.v
+++ b/theories/Classes/theory/ua_third_isomorphism.v
@@ -1,11 +1,13 @@
 (** This file proves the third isomorphism theorem,
     [isomorphic_third_isomorphism]. *)
 Require Import
+  Basics.Notations
   Colimits.Quotient
   Classes.interfaces.canonical_names
   Classes.theory.ua_quotient_algebra
   Classes.theory.ua_isomorphic
-  Classes.theory.ua_first_isomorphism.
+  Classes.theory.ua_first_isomorphism
+  Spaces.List.Core.
 
 Import algebra_notations quotient_algebra_notations isomorphic_notations.
 
diff --git a/theories/Colimits/Coeq.v b/theories/Colimits/Coeq.v
index 7d63ca01de3..30fedec3730 100644
--- a/theories/Colimits/Coeq.v
+++ b/theories/Colimits/Coeq.v
@@ -1,6 +1,5 @@
 Require Import Basics.
 Require Import Types.Paths Types.Arrow Types.Sigma Types.Forall Types.Universe Types.Prod.
-Require Import Cubical.DPath.
 Require Import Colimits.GraphQuotient.
 
 Local Open Scope path_scope.
@@ -54,26 +53,19 @@ Proof.
   rapply GraphQuotient_rec_beta_gqglue.
 Defined.
 
-Definition Coeq_ind_dp {B A f g} (P : @Coeq B A f g -> Type)
-  (coeq' : forall a, P (coeq a))
-  (cglue' : forall b, DPath P (cglue b) (coeq' (f b)) (coeq' (g b)))
-  : forall w, P w.
-Proof.
-  srapply (Coeq_ind P coeq'); intros b.
-  apply dp_path_transport^-1, cglue'.
-Defined.
-
-Definition Coeq_ind_dp_beta_cglue {B A f g} (P : @Coeq B A f g -> Type)
-  (coeq' : forall a, P (coeq a))
-  (cglue' : forall b, DPath P (cglue b) (coeq' (f b)) (coeq' (g b)))
-  (b : B)
-  : dp_apD (Coeq_ind_dp P coeq' cglue') (cglue b) = cglue' b.
+Definition Coeq_ind_hprop {B A f g} (P : @Coeq B A f g -> Type)
+  `{forall x, IsHProp (P x)}
+  (i : forall a, P (coeq a))
+  : forall x, P x.
 Proof.
-  apply dp_apD_path_transport.
-  srapply Coeq_ind_beta_cglue.
+  snrapply Coeq_ind.
+  1: exact i.
+  intros b.
+  rapply path_ishprop.
 Defined.
 
 (** ** Universal property *)
+(** See Colimits/CoeqUnivProp.v for a similar universal property without [Funext]. *)
 
 Definition Coeq_unrec {B A} (f g : B -> A) {P}
   (h : Coeq f g -> P)
@@ -275,59 +267,54 @@ Definition equiv_functor_coeq' {B A f g B' A' f' g'}
 (** ** A double recursion principle *)
 
 Section CoeqRec2.
-  Context `{Funext}
-          {B A : Type} {f g : B -> A} {B' A' : Type} {f' g' : B' -> A'}
-          (P : Type) (coeq' : A -> A' -> P)
-          (cgluel : forall b a', coeq' (f b) a' = coeq' (g b) a')
-          (cgluer : forall a b', coeq' a (f' b') = coeq' a (g' b'))
-          (cgluelr : forall b b', cgluel b (f' b') @ cgluer (g b) b'
-                               = cgluer (f b) b' @ cgluel b (g' b')).
-
-  Definition Coeq_rec2
-  : Coeq f g -> Coeq f' g' -> P.
+  Context {B A : Type} {f g : B -> A} {B' A' : Type} {f' g' : B' -> A'}
+    (P : Type) (coeq' : A -> A' -> P)
+    (cgluel : forall b a', coeq' (f b) a' = coeq' (g b) a')
+    (cgluer : forall a b', coeq' a (f' b') = coeq' a (g' b'))
+    (cgluelr : forall b b', cgluel b (f' b') @ cgluer (g b) b'
+                          = cgluer (f b) b' @ cgluel b (g' b')).
+
+  Definition Coeq_rec2 : Coeq f g -> Coeq f' g' -> P.
   Proof.
-    simple refine (Coeq_rec _ _ _).
+    intros x y; revert x.
+    snrapply Coeq_rec.
     - intros a.
-      simple refine (Coeq_rec _ _ _).
+      revert y.
+      snrapply Coeq_rec.
       + intros a'.
         exact (coeq' a a').
       + intros b'; cbn.
         apply cgluer.
     - intros b.
-      apply path_arrow; intros a.
-      revert a; simple refine (Coeq_ind _ _ _).
-      + intros a'. cbn.
+      revert y.
+      snrapply Coeq_ind.
+      + intros a'.
+        cbn.
         apply cgluel.
-      + intros b'; cbn.
-        refine (transport_paths_FlFr (cglue b') (cgluel b (f' b')) @ _).
-        refine (concat_pp_p _ _ _ @ _).
-        apply moveR_Vp.
-        refine (_ @ cgluelr b b' @ _).
-        * apply whiskerL.
-          apply Coeq_rec_beta_cglue.
-        * apply whiskerR.
-          symmetry; apply Coeq_rec_beta_cglue.
+      + intros b'.
+        nrapply (transport_paths_FlFr' (cglue b')).
+        lhs nrapply (_ @@ 1).
+        1: apply Coeq_rec_beta_cglue.
+        rhs nrapply (1 @@ _).
+        2: apply Coeq_rec_beta_cglue.
+        symmetry.
+        apply cgluelr.
   Defined.
 
   Definition Coeq_rec2_beta (a : A) (a' : A')
-  : Coeq_rec2 (coeq a) (coeq a') = coeq' a a'
+    : Coeq_rec2 (coeq a) (coeq a') = coeq' a a'
     := 1.
 
   Definition Coeq_rec2_beta_cgluel (a : A) (b' : B')
-  : ap (Coeq_rec2 (coeq a)) (cglue b') = cgluer a b'.
+    : ap (Coeq_rec2 (coeq a)) (cglue b') = cgluer a b'.
   Proof.
-    apply Coeq_rec_beta_cglue.
+    nrapply Coeq_rec_beta_cglue.
   Defined.
 
   Definition Coeq_rec2_beta_cgluer (b : B) (a' : A')
-  : ap (fun x => Coeq_rec2 x (coeq a')) (cglue b) = cgluel b a'.
+    : ap (fun x => Coeq_rec2 x (coeq a')) (cglue b) = cgluel b a'.
   Proof.
-    transitivity (ap10 (ap Coeq_rec2 (cglue b)) (coeq a')).
-    - refine (ap_compose Coeq_rec2 (fun h => h (coeq a')) _ @ _).
-      apply ap_apply_l.
-    - unfold Coeq_rec2; rewrite Coeq_rec_beta_cglue.
-      rewrite ap10_path_arrow.
-      reflexivity.
+    nrapply Coeq_rec_beta_cglue.
   Defined.
 
   (** TODO: [Coeq_rec2_beta_cgluelr] *)
diff --git a/theories/Colimits/CoeqUnivProp.v b/theories/Colimits/CoeqUnivProp.v
new file mode 100644
index 00000000000..2a90cb75f0d
--- /dev/null
+++ b/theories/Colimits/CoeqUnivProp.v
@@ -0,0 +1,109 @@
+Require Import Basics.Overture.
+Require Import Basics.Tactics.
+Require Import Basics.PathGroupoids.
+Require Import Types.Paths.
+Require Import Colimits.Coeq.
+Require Import Cubical.DPath.
+Require Import WildCat.Core.
+Require Import WildCat.Displayed.
+Require Import WildCat.Equiv.
+Require Import WildCat.EquivGpd.
+Require Import WildCat.Forall.
+Require Import WildCat.Paths.
+Require Import WildCat.ZeroGroupoid.
+
+(** Using wild 0-groupoids, the universal property can be proven without funext. A simple equivalence of 0-groupoids between [Coeq f g -> P] and [{ h : A -> P & h o f == h o g }] would not carry all the higher-dimensional information, but if we generalize it to dependent functions, then it does suffice. *)
+Section UnivProp.
+  Context {B A : Type} (f g : B -> A) (P : Coeq f g -> Type).
+
+  (** This allows Coq to infer 0-groupoid structures of the form [@isgraph_forall C P (fun c => isgraph_paths (P c))] on any type of the form [forall c, P c].  [isgraph_paths] is not a global instance.  [isgraph_total] is, but we need to adjust the priority.  The other needed ingredients are all global instances. *)
+  Local Existing Instances isgraph_total | 1.
+  Local Existing Instances isgraph_paths | 2.
+
+  (** The codomain of the equivalence is a sigma-groupoid of this family. *)
+  Definition Coeq_ind_data (h : forall a : A, P (coeq a))
+    := forall b : B, DPath P (cglue b) (h (f b)) (h (g b)).
+
+  (** We consider [Coeq_ind_data] to be a displayed 0-groupoid, where objects over [h : forall a : A, P (coeq a)] are dependent paths as defined above and morphisms over [p : h == k] are witnesses that p commutes with the homotopies over [h] and [k]. *)
+  Local Instance isdgraph_Coeq_ind_data : IsDGraph Coeq_ind_data.
+  Proof.
+    intros h k p r s.
+    exact (forall b, ap (transport P (cglue b)) (p (f b)) @ s b = r b @ p (g b)).
+  Defined.
+
+  Local Instance isd01cat_Coeq_ind_data : IsD01Cat Coeq_ind_data.
+  Proof.
+    nrapply Build_IsD01Cat.
+    - intros h h' b; exact (concat_1p_p1 _).
+    - intros h k j p q h' k' j' p' q' b.
+      lhs nrapply ap_pp_p.
+      lhs nrapply (whiskerL _ (p' b)).
+      lhs nrapply concat_p_pp.
+      lhs nrapply (whiskerR (q' b)).
+      nrapply concat_pp_p.
+  Defined.
+
+  Local Instance isd0gpd_Coeq_ind_data : IsD0Gpd Coeq_ind_data.
+  Proof.
+    intros h k p r s p' b.
+    lhs nrapply (whiskerR (ap_V _ _)).
+    nrapply moveL_pV.
+    lhs nrapply concat_pp_p.
+    lhs nrapply (whiskerL _ (p' b)^).
+    lhs nrapply concat_p_pp.
+    lhs nrapply (whiskerR (concat_Vp _)).
+    nrapply concat_1p.
+  Defined.
+
+  (** Here is the functor. The domain is the fully-applied type of [Coeq_ind]: sections of [P] over [Coeq f g]. The codomain consists of input data for [Coeq_ind] given a 0-groupoid structure via [is0gpd_total]. *)
+  Definition Coeq_ind_inv : (forall z : Coeq f g, P z) -> sig Coeq_ind_data.
+  Proof.
+    intros h.
+    exists (h o coeq).
+    intros b.
+    exact (apD h (cglue b)).
+  Defined.
+
+  (** Use [Set Printing Implicit] to see the 0-groupoid structures described above. *)
+  Local Instance is0functor_Coeq_ind_inv : Is0Functor Coeq_ind_inv.
+  Proof.
+    nrapply Build_Is0Functor.
+    intros h k p.
+    exists (p o coeq).
+    intros b.
+    nrapply moveL_pM.
+    exact ((apD_homotopic p (cglue b))^).
+  Defined.
+
+  Local Instance issurjinj_Coeq_ind_inv : IsSurjInj Coeq_ind_inv.
+  Proof.
+    nrapply Build_IsSurjInj.
+    - intros [h r].
+      exists (Coeq_ind P h r).
+      exists (fun a => idpath).
+      intros b.
+      nrefine (concat_1p _ @ _ @ (concat_p1 _)^).
+      symmetry.
+      nrapply Coeq_ind_beta_cglue.
+    - intros h k [p p'].
+      snrapply Coeq_ind.
+      1: exact p.
+      intros b; specialize (p' b).
+      lhs nrapply transport_paths_FlFr_D.
+      lhs nrapply concat_pp_p.
+      lhs nrapply (whiskerL _ p').
+      lhs nrapply concat_p_pp.
+      lhs nrapply (whiskerR (concat_Vp _)).
+      nrapply concat_1p.
+  Defined.
+
+  Definition equiv_0gpd_Coeq_ind
+    : Build_ZeroGpd (forall z : Coeq f g, P z) _ _ _
+      $<~> Build_ZeroGpd (sig Coeq_ind_data) _ _ _.
+  Proof.
+    snrapply Build_CatEquiv.
+    1: rapply Build_Morphism_0Gpd.
+    rapply isequiv_0gpd_issurjinj.
+  Defined.
+
+End UnivProp.
diff --git a/theories/Colimits/GraphQuotient.v b/theories/Colimits/GraphQuotient.v
index 560d16a8fcb..345a7cd9a9d 100644
--- a/theories/Colimits/GraphQuotient.v
+++ b/theories/Colimits/GraphQuotient.v
@@ -1,5 +1,5 @@
 Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Equivalences.
-Require Import Types.Universe Types.Paths Types.Arrow Types.Sigma Types.Forall Cubical.DPath.
+Require Import Types.Universe Types.Paths Types.Arrow Types.Sigma Cubical.DPath.
 
 (** * Quotient of a graph *)
 
@@ -116,7 +116,6 @@ Section Flattening.
   Lemma equiv_dp_dgraphquotient (x y : A) (s : R x y) (a : F x) (b : F y)
     : DPath DGraphQuotient (gqglue s) a b <~> (e x y s a = b).
   Proof.
-    refine (_ oE dp_path_transport^-1).
     refine (equiv_concat_l _^ _).
     apply transport_DGraphQuotient.
   Defined.
@@ -132,21 +131,17 @@ Section Flattening.
     snrapply GraphQuotient_ind.
     1: exact Qgq.
     intros a b s.
-    apply equiv_dp_path_transport.
     apply dp_forall.
     intros x y.
     srapply (equiv_ind (equiv_dp_dgraphquotient a b s x y)^-1).
     intros q.
     destruct q.
-    apply equiv_dp_path_transport.
     refine (transport2 _ _ _ @ Qgqglue a b s x).
     refine (ap (path_sigma_uncurried DGraphQuotient _ _) _).
     snrapply path_sigma.
     1: reflexivity.
-    apply moveR_equiv_V.
-    simpl; f_ap.
-    lhs rapply concat_p1.
-    rapply inv_V.
+    lhs nrapply concat_p1.
+    apply inv_V.
   Defined.
 
   (** Rather than use [flatten_ind] to define [flatten_rec] we reprove this simple case. This means we can later reason about it and derive the computation rules easily. The full computation rule for [flatten_ind] takes some work to derive and is not actually needed. *)
diff --git a/theories/Colimits/MappingCylinder.v b/theories/Colimits/MappingCylinder.v
index 9f2640f9bac..1e7ae14eb7a 100644
--- a/theories/Colimits/MappingCylinder.v
+++ b/theories/Colimits/MappingCylinder.v
@@ -33,41 +33,24 @@ Section MappingCylinder.
             (cylb : forall b, P (cyr b))
             (cylg : forall a, DPath P (cyglue a) (cyla a) (cylb (f a))).
 
-    Definition Cyl_ind_dp : forall c, P c.
-    Proof.
-      srapply Pushout_ind.
-      - apply cyla.
-      - apply cylb.
-      - intros a; apply dp_path_transport^-1, cylg.
-    Defined.
-
-    Definition Cyl_ind_dp_beta_cyglue (a : A)
-      : dp_apD Cyl_ind_dp (cyglue a) = cylg a.
-    Proof.
-      unfold Cyl_ind_dp.
-      refine ((dp_path_transport_apD _ _)^ @ _).
-      apply moveR_equiv_M.
-      rapply Pushout_ind_beta_pglue.
-    Defined.
+    Definition Cyl_ind : forall c, P c
+      := Pushout_ind _ cyla cylb cylg.
+
+    Definition Cyl_ind_beta_cyglue (a : A)
+      : apD Cyl_ind (cyglue a) = cylg a
+      := Pushout_ind_beta_pglue _ _ _ _ _.
 
   End CylInd.
 
   Section CylRec.
     Context {P : Type} (cyla : A -> P) (cylb : B -> P) (cylg : cyla == cylb o f).
 
-    Definition Cyl_rec : Cyl f -> P.
-    Proof.
-      srapply Pushout_rec.
-      - apply cyla.
-      - apply cylb.
-      - apply cylg.
-    Defined.
+    Definition Cyl_rec : Cyl f -> P
+      := Pushout_rec _ cyla cylb cylg.
 
     Definition Cyl_rec_beta_cyglue (a : A)
-      : ap Cyl_rec (cyglue a) = cylg a.
-    Proof.
-      rapply Pushout_rec_beta_pglue.
-    Defined.
+      : ap Cyl_rec (cyglue a) = cylg a
+      := Pushout_rec_beta_pglue _ _ _ _ _.
 
   End CylRec.
 
@@ -82,7 +65,7 @@ Section MappingCylinder.
       + exact f.
       + exact idmap.
       + reflexivity.
-    - srapply Cyl_ind_dp.
+    - srapply Cyl_ind.
       + intros a; cbn.
         symmetry; apply cyglue.
       + intros b; reflexivity.
diff --git a/theories/Colimits/Quotient.v b/theories/Colimits/Quotient.v
index 956db3f2ed4..3ee2c9cb201 100644
--- a/theories/Colimits/Quotient.v
+++ b/theories/Colimits/Quotient.v
@@ -4,10 +4,11 @@ Require Import HSet.
 Require Import TruncType.
 Require Import Colimits.GraphQuotient.
 Require Import Truncations.Core.
+Require Import PropResizing.
 
 Local Open Scope path_scope.
 
-(** * Quotient of a type by an hprop-valued relation
+(** * The set-quotient of a type by an hprop-valued relation
 
 We aim to model:
 <<
@@ -16,7 +17,9 @@ Inductive Quotient R : Type :=
    | qglue : forall x y, (R x y) -> class_of R x = class_of R y
    | ishset_quotient : IsHSet (Quotient R)
 >>
-We do this by defining the quotient as a 0-truncated graph quotient. *)
+We do this by defining the quotient as a 0-truncated graph quotient. 
+
+Throughout this file [a], [b] and [c] are elements of [A], [R] is a relation on [A], [x], [y] and [z] are elements of [Quotient R], [p] is a proof of [R a b]. *)
 
 Definition Quotient@{i j k} {A : Type@{i}} (R : Relation@{i j} A) : Type@{k}
   := Trunc@{k} 0 (GraphQuotient@{i j k} R).
@@ -24,39 +27,37 @@ Definition Quotient@{i j k} {A : Type@{i}} (R : Relation@{i j} A) : Type@{k}
 Definition class_of@{i j k} {A : Type@{i}} (R : Relation@{i j} A)
   : A -> Quotient@{i j k} R := tr o gq.
 
-Definition qglue@{i j k} {A : Type@{i}} {R : Relation@{i j} A}
-  {x y : A}
-  : R x y -> class_of@{i j k} R x = class_of R y
+Definition qglue@{i j k} {A : Type@{i}} {R : Relation@{i j} A} {a b : A}
+  : R a b -> class_of@{i j k} R a = class_of R b
   := fun p => ap tr (gqglue p).
 
 Global Instance ishset_quotient {A : Type} (R : Relation A)
   : IsHSet (Quotient R) := _.
 
-Definition Quotient_ind@{i j k l}
-  {A : Type@{i}} (R : Relation@{i j} A)
+Definition Quotient_ind@{i j k l} {A : Type@{i}} (R : Relation@{i j} A)
   (P : Quotient@{i j k} R -> Type@{l}) {sP : forall x, IsHSet (P x)}
-  (pclass : forall x, P (class_of R x))
-  (peq : forall x y (H : R x y), qglue H # pclass x = pclass y)
-  : forall q, P q.
+  (pclass : forall a, P (class_of R a))
+  (peq : forall a b (H : R a b), qglue H # pclass a = pclass b)
+  : forall x, P x.
 Proof.
-  eapply Trunc_ind, GraphQuotient_ind.
-  1: assumption.
-  intros a b p.
-  refine (transport_compose _ _ _ _ @ _).
-  apply peq.
+  rapply Trunc_ind; srapply GraphQuotient_ind.
+  - exact pclass.
+  - intros a b p.
+    lhs nrapply (transport_compose P).
+    exact (peq a b p).
 Defined.
 
 Definition Quotient_ind_beta_qglue@{i j k l}
   {A : Type@{i}} (R : Relation@{i j} A)
   (P : Quotient@{i j k} R -> Type@{l}) {sP : forall x, IsHSet (P x)}
-  (pclass : forall x, P (class_of R x))
-  (peq : forall x y (H : R x y), qglue H # pclass x = pclass y)
-  (x y : A) (p : R x y)
-  : apD (Quotient_ind@{i j k l} R P pclass peq) (qglue p) = peq x y p.
+  (pclass : forall a, P (class_of R a))
+  (peq : forall a b (H : R a b), qglue H # pclass a = pclass b)
+  (a b : A) (p : R a b)
+  : apD (Quotient_ind@{i j k l} R P pclass peq) (qglue p) = peq a b p.
 Proof.
-  refine (apD_compose' tr _ _ @ _).
+  lhs nrapply apD_compose'.
   unfold Quotient_ind.
-  refine (ap _ (GraphQuotient_ind_beta_gqglue _ pclass
+  nrefine (ap _ (GraphQuotient_ind_beta_gqglue _ pclass
     (fun a b p0 => transport_compose P tr _ _ @ peq a b p0) _ _ _) @ _).
   rapply concat_V_pp.
 Defined.
@@ -64,22 +65,23 @@ Defined.
 Definition Quotient_rec@{i j k l}
   {A : Type@{i}} (R : Relation@{i j} A)
   (P : Type@{l}) `{IsHSet P} (pclass : A -> P)
-  (peq : forall x y, R x y -> pclass x = pclass y)
+  (peq : forall a b, R a b -> pclass a = pclass b)
   : Quotient@{i j k} R -> P.
 Proof.
-  eapply Trunc_rec, GraphQuotient_rec.
-  apply peq.
+  srapply Trunc_rec; snrapply GraphQuotient_rec.
+  - exact pclass.
+  - exact peq.
 Defined.
 
 Definition Quotient_rec_beta_qglue @{i j k l}
   {A : Type@{i}} (R : Relation@{i j} A)
   (P : Type@{l}) `{IsHSet P} (pclass : A -> P)
-  (peq : forall x y, R x y -> pclass x = pclass y)
-  (x y : A) (p : R x y)
-  : ap (Quotient_rec@{i j k l} R P pclass peq) (qglue p) = peq x y p.
+  (peq : forall a b, R a b -> pclass a = pclass b)
+  (a b : A) (p : R a b)
+  : ap (Quotient_rec@{i j k l} R P pclass peq) (qglue p) = peq a b p.
 Proof.
-  refine ((ap_compose tr _ _)^ @ _).
-  srapply GraphQuotient_rec_beta_gqglue.
+  lhs_V nrapply (ap_compose tr).
+  snrapply GraphQuotient_rec_beta_gqglue.
 Defined.
 
 Arguments Quotient : simpl never.
@@ -90,6 +92,36 @@ Arguments Quotient_rec_beta_qglue : simpl never.
 
 Notation "A / R" := (Quotient (A:=A) R).
 
+(* Quotient induction into a hprop. *)
+Definition Quotient_ind_hprop {A : Type@{i}} (R : Relation@{i j} A)
+  (P : A / R -> Type) `{forall x, IsHProp (P x)}
+  (dclass : forall a, P (class_of R a))
+  : forall x, P x.
+Proof.
+  srapply (Quotient_ind R P dclass).
+  intros x y p; apply path_ishprop.
+Defined.
+
+Definition Quotient_ind2_hprop {A : Type@{i}} (R : Relation@{i j} A)
+  (P : A / R -> A / R -> Type) `{forall x y, IsHProp (P x y)}
+  (dclass : forall a b, P (class_of R a) (class_of R b))
+  : forall x y, P x y.
+Proof.
+  intros x; srapply Quotient_ind_hprop; intros b.
+  revert x; srapply Quotient_ind_hprop; intros a.
+  exact (dclass a b).
+Defined.
+
+Definition Quotient_ind3_hprop {A : Type@{i}} (R : Relation@{i j} A)
+  (P : A / R -> A / R -> A / R -> Type) `{forall x y z, IsHProp (P x y z)}
+  (dclass : forall a b c, P (class_of R a) (class_of R b) (class_of R c))
+  : forall x y z, P x y z.
+Proof.
+  intros x; srapply Quotient_ind2_hprop; intros b c.
+  revert x; srapply Quotient_ind_hprop; intros a.
+  exact (dclass a b c).
+Defined.
+
 Section Equiv.
 
   Context `{Univalence} {A : Type} (R : Relation A) `{is_mere_relation _ R}
@@ -98,95 +130,76 @@ Section Equiv.
   (* The proposition of being in a given class in a quotient. *)
   Definition in_class : A / R -> A -> HProp.
   Proof.
-    srapply Quotient_ind.
-    { intros a b.
-      exact (Build_HProp (R a b)). }
-    intros x y p.
-    refine (transport_const _ _ @ _).
-    funext z.
+    intros x b; revert x.
+    srapply Quotient_rec.
+    1: intro a; exact (Build_HProp (R a b)).
+    intros a c p; cbn beta.
     apply path_hprop.
     srapply equiv_iff_hprop; cbn.
     1: apply (transitivity (symmetry _ _ p)).
     apply (transitivity p).
   Defined.
 
-  (* Quotient induction into a hprop. *)
-  Definition Quotient_ind_hprop
-    (P : A / R -> Type) `{forall x, IsHProp (P x)}
-    (dclass : forall x, P (class_of R x)) : forall q, P q.
-  Proof.
-    srapply (Quotient_ind R P dclass).
-    all: try (intro; apply trunc_succ).
-    intros x y p.
-    apply path_ishprop.
-  Defined.
-
   (* Being in a class is decidable if the Relation is decidable. *)
-  Global Instance decidable_in_class `{forall x y, Decidable (R x y)}
+  Global Instance decidable_in_class `{forall a b, Decidable (R a b)}
   : forall x a, Decidable (in_class x a).
   Proof.
     by srapply Quotient_ind_hprop.
   Defined.
 
   (* if x is in a class q, then the class of x is equal to q. *)
-  Lemma path_in_class_of : forall q x, in_class q x -> q = class_of R x.
+  Lemma path_in_class_of : forall x a, in_class x a -> x = class_of R a.
   Proof.
     srapply Quotient_ind.
     { intros x y p.
-      apply (qglue p). }
+      exact (qglue p). }
     intros x y p.
     funext ? ?.
     apply hset_path2.
   Defined.
 
-  Lemma related_quotient_paths : forall x y,
-    class_of R x = class_of R y -> R x y.
+  Lemma related_quotient_paths (a b : A)
+    : class_of R a = class_of R b -> R a b.
   Proof.
-    intros x y p.
-    change (in_class (class_of R x) y).
+    intros p.
+    change (in_class (class_of R a) b).
     destruct p^.
     cbv; reflexivity.
   Defined.
 
   (** Thm 10.1.8 *)
-  Theorem path_quotient : forall x y,
-    R x y <~> (class_of R x = class_of R y).
+  Theorem path_quotient (a b : A)
+    : R a b <~> (class_of R a = class_of R b).
   Proof.
-    intros ??.
     apply equiv_iff_hprop.
     - apply qglue.
     - apply related_quotient_paths.
   Defined.
 
-  Definition Quotient_rec2 `{Funext} {B : HSet} {dclass : A -> A -> B}
-    {dequiv : forall x x', R x x' -> forall y y',
-      R y y' -> dclass x y = dclass x' y'}
+  Definition Quotient_rec2 {B : Type} `{IsHSet B} {dclass : A -> A -> B}
+    {dequiv : forall a a', R a a' -> forall b b',
+      R b b' -> dclass a b = dclass a' b'}
     : A / R -> A / R -> B.
   Proof.
+    clear H. (* Ensure that we don't use Univalence. *)
+    intro x.
     srapply Quotient_rec.
-    { intro a.
+    - intro b.
+      revert x.
       srapply Quotient_rec.
-      { revert a.
-        assumption. }
-      by apply (dequiv a a). }
-    intros x y p.
-    apply path_forall.
-    srapply Quotient_ind.
-    { cbn; intro a.
-      by apply dequiv. }
-    intros a b q.
-    apply path_ishprop.
-  Defined.
-
-  Definition Quotient_ind_hprop' (P : A / R -> Type)
-    `{forall x, IsHProp (P (class_of _ x))}
-    (dclass : forall x, P (class_of _ x)) : forall y, P y.
-  Proof.
-    apply Quotient_ind with dclass.
-    { srapply Quotient_ind.
-      1: intro; apply istrunc_succ.
-      intros ???; apply path_ishprop. }
-    intros; apply path_ishprop.
+      + intro a.
+        exact (dclass a b).
+      + cbn beta.
+        intros a a' p.
+        by apply (dequiv a a' p b b).
+    - cbn beta.
+      intros b b' p.
+      revert x.
+      srapply Quotient_ind.
+      + cbn; intro a.
+        by apply dequiv.
+      + intros a a' q.
+        apply path_ishprop.
   Defined.
 
   (** The map class_of : A -> A/R is a surjection. *)
@@ -194,15 +207,15 @@ Section Equiv.
   Proof.
     apply BuildIsSurjection.
     srapply Quotient_ind_hprop.
-    intro x.
+    intro a.
     apply tr.
-    by exists x.
+    by exists a.
   Defined.
 
   (* Universal property of quotient *)
   (* Lemma 6.10.3 *)
-  Theorem equiv_quotient_ump (B : HSet)
-    : (A / R -> B) <~> {f : A -> B & forall x y, R x y -> f x = f y}.
+  Theorem equiv_quotient_ump (B : Type) `{IsHSet B}
+    : (A / R -> B) <~> {f : A -> B & forall a b, R a b -> f a = f b}.
   Proof.
     srapply equiv_adjointify.
     + intro f.
@@ -239,12 +252,12 @@ Section Functoriality.
   Definition Quotient_functor
     {A : Type} (R : Relation A)
     {B : Type} (S : Relation B)
-    (f : A -> B) (fresp : forall x y, R x y -> S (f x) (f y))
+    (f : A -> B) (fresp : forall a b, R a b -> S (f a) (f b))
     : Quotient R -> Quotient S.
   Proof.
     refine (Quotient_rec R _ (class_of S o f) _).
-    intros x y r.
-    apply qglue, fresp, r.
+    intros a b p.
+    apply qglue, fresp, p.
   Defined.
 
   Definition Quotient_functor_idmap
@@ -258,9 +271,9 @@ Section Functoriality.
     {A : Type} {R : Relation A}
     {B : Type} {S : Relation B}
     {C : Type} {T : Relation C}
-    (f : A -> B) (fresp : forall x y, R x y -> S (f x) (f y))
-    (g : B -> C) (gresp : forall x y, S x y -> T (g x) (g y))
-    : Quotient_functor R T (g o f) (fun x y => (gresp _ _) o (fresp x y))
+    (f : A -> B) (fresp : forall a b, R a b -> S (f a) (f b))
+    (g : B -> C) (gresp : forall a b, S a b -> T (g a) (g b))
+    : Quotient_functor R T (g o f) (fun a b => (gresp _ _) o (fresp a b))
     == Quotient_functor S T g gresp o Quotient_functor R S f fresp.
   Proof.
     by srapply Quotient_ind_hprop.
@@ -270,11 +283,11 @@ Section Functoriality.
           {B : Type} (S : Relation B).
 
   Global Instance isequiv_quotient_functor (f : A -> B)
-    (fresp : forall x y, R x y <-> S (f x) (f y)) `{IsEquiv _ _ f}
-    : IsEquiv (Quotient_functor R S f (fun x y => fst (fresp x y))).
+    (fresp : forall a b, R a b <-> S (f a) (f b)) `{IsEquiv _ _ f}
+    : IsEquiv (Quotient_functor R S f (fun a b => fst (fresp a b))).
   Proof.
     srapply (isequiv_adjointify _ (Quotient_functor S R f^-1 _)).
-    { intros u v s.
+    { intros a b s.
       apply (snd (fresp _ _)).
       abstract (do 2 rewrite eisretr; apply s). }
     all: srapply Quotient_ind.
@@ -287,12 +300,12 @@ Section Functoriality.
   Defined.
 
   Definition equiv_quotient_functor (f : A -> B) `{IsEquiv _ _ f}
-    (fresp : forall x y, R x y <-> S (f x) (f y))
+    (fresp : forall a b, R a b <-> S (f a) (f b))
     : Quotient R <~> Quotient S
-    := Build_Equiv _ _ (Quotient_functor R S f (fun x y => fst (fresp x y))) _.
+    := Build_Equiv _ _ (Quotient_functor R S f (fun a b => fst (fresp a b))) _.
 
   Definition equiv_quotient_functor' (f : A <~> B)
-    (fresp : forall x y, R x y <-> S (f x) (f y))
+    (fresp : forall a b, R a b <-> S (f a) (f b))
     : Quotient R <~> Quotient S
     := equiv_quotient_functor f fresp.
 
@@ -300,32 +313,33 @@ End Functoriality.
 
 Section Kernel.
 
-  (* TODO: Properly annotate with universes *)
-
   (** ** Quotients of kernels of maps to sets give a surjection/mono factorization. *)
 
+  (** Because the statement uses nested Sigma types, we need several variables to serve as [max] and [u+1]. We write [ar] for [max(a,r)], [ar'] for [ar+1], etc. *)
+  Universes a r ar ar' b ab abr.
+  Constraint a <= ar, r <= ar, ar < ar', a <= ab, b <= ab, ab <= abr, ar <= abr.
+
   Context `{Funext}.
-  Universe i.
 
   (** A function we want to factor. *)
-  Context {A : Type@{i}} {B : Type} `{IsHSet B} (f : A -> B).
+  Context {A : Type@{a}} {B : Type@{b}} `{IsHSet B} (f : A -> B).
 
   (** A mere Relation equivalent to its kernel. *)
-  Context (R : Relation A)
+  Context (R : Relation@{a r} A)
           (is_ker : forall x y, f x = f y <~> R x y).
 
-  Theorem quotient_kernel_factor
-    : exists (C : Type@{i}) (e : A -> C) (m : C -> B),
+  (** The factorization theorem.  An advantage of stating it as one bundled result is that it is easier to state variations as we do below.  Disadvantages are that it requires more universe variables and that each piece of the answer depends on [Funext] and all of the universe variables, even when these aren't needed for that piece.  Below we will clean up the universe variables slightly, so we make this version [Local]. *)
+  Local Definition quotient_kernel_factor_internal
+    : exists (C : Type@{ar}) (e : A -> C) (m : C -> B),
       IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e).
   Proof.
     exists (Quotient R).
     exists (class_of R).
     srefine (_;_).
-    { apply Quotient_ind with f; try exact _.
+    { refine (Quotient_ind R (fun _ => B) f _).
       intros x y p.
-      transitivity (f x).
-      - apply transport_const.
-      - exact ((is_ker x y)^-1 p). }
+      lhs nrapply transport_const.
+      exact ((is_ker x y)^-1 p). }
     repeat split; try exact _.
     intro u.
     apply hprop_allpath.
@@ -342,4 +356,30 @@ Section Kernel.
     exact (p @ p'^).
   Defined.
 
+  (** We clean up the universe variables here, using only those declared in this Section. *)
+  Definition quotient_kernel_factor_general@{|}
+    := Eval unfold quotient_kernel_factor_internal in
+      quotient_kernel_factor_internal@{ar' ar abr abr ab abr abr}.
+
 End Kernel.
+
+(** A common special case of [quotient_kernel_factor] is when we define [R] to be [f x = f y].  Then universes [r] and [b] are unified. *)
+Definition quotient_kernel_factor@{a b ab ab' | a <= ab, b <= ab, ab < ab'}
+  `{Funext} {A : Type@{a}} {B : Type@{b}} `{IsHSet B} (f : A -> B)
+  : exists (C : Type@{ab}) (e : A -> C) (m : C -> B),
+      IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e).
+Proof.
+  exact (quotient_kernel_factor_general@{a b ab ab' b ab ab}
+           f (fun a b => f a = f b) (fun x y => equiv_idmap)).
+Defined.
+
+(** If we use propositional resizing, we can replace [f x = f y] with a proposition [R x y] in universe [a], so that the universe of [C] is the same as the universe of [A]. *)
+Definition quotient_kernel_factor_small@{a a' b ab | a < a', a <= ab, b <= ab}
+  `{Funext} `{PropResizing}
+  {A : Type@{a}} {B : Type@{b}} `{IsHSet B} (f : A -> B)
+  : exists (C : Type@{a}) (e : A -> C) (m : C -> B),
+      IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e).
+Proof.
+  exact (quotient_kernel_factor_general@{a a a a' b ab ab}
+           f (fun a b => resize_hprop@{b a} (f a = f b)) (fun x y => equiv_resize_hprop _)).
+Defined.
diff --git a/theories/Colimits/Sequential.v b/theories/Colimits/Sequential.v
index a42de66a1ab..65906d9b35b 100644
--- a/theories/Colimits/Sequential.v
+++ b/theories/Colimits/Sequential.v
@@ -187,8 +187,8 @@ Proof.
   destruct p; reflexivity.
 Defined.
 
-Local Definition J {X Y Z} {x1 x2 : X} {y} {I : forall x, Y x -> Z} (p : x1 = x2)
-  : I x2 y = I x1 (coe (ap Y p^) y).
+Local Definition J {X Y Z} {x1 x2 : X} {y} {I : forall x, Y x -> Z} (p : x2 = x1)
+  : I x2 y = I x1 (coe (ap Y p) y).
 Proof.
   destruct p; reflexivity.
 Defined.
@@ -199,13 +199,15 @@ Proof.
   destruct p; reflexivity.
 Defined.
 
-Local Definition L {X Y Z} {x1 x2 : X} {y} {F G} {I : forall x, Y x -> Z} {p : x1 = x2}
+Local Definition L {X Y Z} {x1 x2 : X} {y} {F G} {I : forall x, Y x -> Z} {p : x2 = x1}
   (Q : forall x y, I (F x) (G x y) = I x y)
   : Q x2 y @ J p =
-    J (ap F p) @ (ap (I (F x1)) (K F G p^ @ ap10 (ap coe (ap (ap Y) (ap_V F p))) (G x2 y))^ @
-    Q x1 (coe (ap Y p^) y)).
+    J (ap F p) @ (ap (I (F x1)) (K F G p)^ @
+    Q x1 (coe (ap Y p) y)).
 Proof.
-  destruct p; rewrite !concat_1p, concat_p1; reflexivity.
+  destruct p; cbn.
+  apply equiv_p1_1q.
+  symmetry; apply concat_1p.
 Defined.
 
 Global Instance isequiv_colim_shift_seq_to_colim_seq `{Funext} A n
@@ -214,23 +216,21 @@ Proof.
   induction n as [ | n e]; srapply isequiv_homotopic'.
   - srapply equiv_functor_colimit; srapply Build_diagram_equiv.
     + srapply Build_DiagramMap.
-      * exact (fun k => coe (ap A (add_n_O k)^)).
-      * intros k l p a; destruct p; srapply (K S (fun n a => a^+) (add_n_O k)^ @ _).
-        srapply (ap10 (ap coe (ap (ap _) (ap_V _ _)))).
+      * exact (fun k => coe (ap A (nat_add_zero_r k))).
+      * intros k l p a; destruct p. srapply (K S (fun n a => a^+) _).
     + exact _.
   - symmetry; srapply seq_colimit_uniq.
-    + intros k a; exact (J (add_n_O k)).
+    + intros k a; exact (J (nat_add_zero_r k)).
     + intros k a; rewrite !Colimit_rec_beta_colimp; srapply (L (glue A)).
   - transitivity (Colimit (succ_seq (shift_seq A n))).
     + srapply equiv_functor_colimit; srapply Build_diagram_equiv.
       * srapply Build_DiagramMap.
-        { exact (fun k => coe (ap A (nat_add_n_Sm k n)^)). }
-        { intros k l p a; destruct p; rapply (K S (fun n a => a^+) (nat_add_n_Sm k n)^ @ _).
-          srapply (ap10 (ap coe (ap (ap _) (ap_V _ _)))). }
+        { exact (fun k => coe (ap A (nat_add_succ_r k n))). }
+        { intros k l p a; destruct p; rapply (K S (fun n a => a^+) (nat_add_succ_r k n)). }
       * exact _.
     + srefine (transitivity (equiv_colim_succ_seq_to_colim_seq _) (Build_Equiv _ _ _ e)).
   - symmetry; srapply seq_colimit_uniq.
-    + intros k a; exact (J (nat_add_n_Sm k n)).
+    + intros k a; exact (J (nat_add_succ_r k n)).
     + intros k a; rewrite Colimit_rec_beta_colimp; simpl.
       rewrite 2(ap_compose' _ _ (glue _ k a)), Colimit_rec_beta_colimp, 2ap_pp.
       rewrite colim_succ_seq_to_colim_seq_ap_inj, colim_shift_seq_to_colim_seq_ap_inj.
diff --git a/theories/Cubical/DPath.v b/theories/Cubical/DPath.v
index 9b0970db62a..6595ac696db 100644
--- a/theories/Cubical/DPath.v
+++ b/theories/Cubical/DPath.v
@@ -7,52 +7,30 @@ Delimit Scope dpath_scope with dpath.
 Local Open Scope dpath_scope.
 
 Definition DPath {A} (P : A -> Type) {a0 a1} (p : a0 = a1)
-  (b0 : P a0) (b1 : P a1) : Type.
-Proof.
-  destruct p.
-  exact (b0 = b1).
-Defined.
+  (b0 : P a0) (b1 : P a1) : Type
+  := transport P p b0 = b1.
 
-(* This allows DPaths to collapse to paths under cbn *)
+(** This allows DPaths to collapse to paths under cbn *)
 Arguments DPath _ / _ _ _ : simpl nomatch.
 
-(* Here is an alternative definition of DPath, for now the original suffices *)
-(* Definition DPath {A} (P : A -> Type) {a0 a1} (p : a0 = a1)
-  (b0 : P a0) (b1 : P a1) := transport P p b0 = b1.  *)
-
-(* We can prove they are equivalent anyway *)
-Definition equiv_dp_path_transport {A : Type} {P : A -> Type}
-           {a0 a1 : A} {p : a0 = a1} {b0 : P a0} {b1 : P a1}
-  : transport P p b0 = b1 <~> DPath P p b0 b1.
-Proof.
-  by destruct p.
-Defined.
-
-(** We abbreviate many names that are equivalences *)
-Notation dp_path_transport := equiv_dp_path_transport.
-
 Global Instance istrunc_dp {A : Type} {P : A -> Type} {n : trunc_index}
  {a0 a1} {p : a0 = a1} {b0 : P a0} {b1 : P a1} `{IsTrunc n.+1 (P a0)}
-  `{IsTrunc n.+1 (P a1)} : IsTrunc n (DPath P p b0 b1).
-Proof.
-  exact (istrunc_equiv_istrunc _ dp_path_transport).
-Defined.
+  `{IsTrunc n.+1 (P a1)} : IsTrunc n (DPath P p b0 b1) := _.
 
 Definition dp_ishprop {A : Type} (P : A -> Type) {a0 a1} {p : a0 = a1}
   {b0 : P a0} {b1 : P a1} `{IsHProp (P a0)} `{IsHProp (P a1)}
   : DPath P p b0 b1.
 Proof.
-  apply dp_path_transport, path_ishprop.
+  apply path_ishprop.
 Defined.
 
-(* We have reflexivity for DPaths, this helps coq guess later *)
+(** We have reflexivity for DPaths, this helps coq guess later *)
 Definition dp_id {A} {P : A -> Type} {a : A} {x : P a} : DPath P 1 x x := 1%path.
 
-(* Althought 1%dpath is definitionally 1%path, coq cannot guess this so it helps
-   to have 1 be a dpath before hand. *)
+(** Although [1%dpath] is definitionally [1%path], when [1%path] is used where a dependent path is expected, Coq sometimes has trouble interpreting this. So we make a custom notation for [1] in [dpath_scope]. *)
 Notation "1" := dp_id : dpath_scope.
 
-(* DPath induction *)
+(** DPath induction *)
 Definition DPath_ind (A : Type) (P : A -> Type) (P0 : forall (a0 a1 : A)
   (p : a0 = a1) (b0 : P a0) (b1 : P a1), DPath P p b0 b1 -> Type)
   : (forall (x : A) (y : P x), P0 x x 1%path y y 1) ->
@@ -62,21 +40,7 @@ Proof.
   intros X a0 a1 [] b0 b1 []; apply X.
 Defined.
 
-(* DPath version of apD *)
-Definition dp_apD {A P} (f : forall a, P a) {a0 a1 : A}
-  (p : a0 = a1) : DPath P p (f a0) (f a1).
-Proof.
-  by destruct p.
-Defined.
-
-(* which corresponds to ordinary apD *)
-Definition dp_path_transport_apD {A P} (f : forall a, P a) {a0 a1 : A} (p : a0 = a1)
-  : dp_path_transport (apD f p) = dp_apD f p.
-Proof.
-  by destruct p.
-Defined.
-
-(* A DPath over a constant family is just a path *)
+(** A DPath over a constant family is just a path *)
 Definition equiv_dp_const {A C} {a0 a1 : A} {p : a0 = a1} {x y}
   : (x = y) <~> DPath (fun _ => C) p x y.
 Proof.
@@ -85,22 +49,22 @@ Defined.
 
 Notation dp_const := equiv_dp_const.
 
-(* dp_apD of a non-dependent map is just a constant DPath *)
+(** dp_apD of a non-dependent map is just a constant DPath *)
 Definition dp_apD_const {A B} (f : A -> B) {a0 a1 : A}
-  (p : a0 = a1) : dp_apD f p = dp_const (ap f p).
+  (p : a0 = a1) : apD f p = dp_const (ap f p).
 Proof.
   by destruct p.
 Defined.
 
-(* An alternate version useful for proving recursion computation rules from induction ones *)
+(** An alternate version useful for proving recursion computation rules from induction ones *)
 Definition dp_apD_const' {A B : Type} {f : A -> B} {a0 a1 : A}
-  {p : a0 = a1} : dp_const^-1 (dp_apD f p) = ap f p.
+  {p : a0 = a1} : dp_const^-1 (apD f p) = ap f p.
 Proof.
   apply moveR_equiv_V.
   apply dp_apD_const.
 Defined.
 
-(* Concatenation of dependent paths *)
+(** Concatenation of dependent paths *)
 Definition dp_concat {A} {P : A -> Type} {a0 a1 a2}
   {p : a0 = a1} {q : a1 = a2} {b0 : P a0} {b1 : P a1} {b2 : P a2}
   : DPath P p b0 b1 -> DPath P q b1 b2 -> DPath P (p @ q) b0 b2.
@@ -111,7 +75,7 @@ Defined.
 
 Notation "x '@Dp' y" := (dp_concat x y) : dpath_scope.
 
-(* Concatenation of dependent paths with non-dependent paths *)
+(** Concatenation of dependent paths with non-dependent paths *)
 Definition dp_concat_r {A} {P : A -> Type} {a0 a1}
   {p : a0 = a1} {b0 : P a0} {b1 b2 : P a1}
   : DPath P p b0 b1 -> (b1 = b2) -> DPath P p b0 b2.
@@ -130,7 +94,7 @@ Defined.
 
 Notation "x '@Dl' y" := (dp_concat_l x y) : dpath_scope.
 
-(* Inverse of dependent paths *)
+(** Inverse of dependent paths *)
 Definition dp_inverse {A} {P : A -> Type} {a0 a1} {p : a0 = a1}
   {b0 : P a0} {b1 : P a1} : DPath P p b0 b1 -> DPath P p^ b1 b0.
 Proof.
@@ -140,22 +104,22 @@ Defined.
 
 Notation "x '^D'" := (dp_inverse x) : dpath_scope.
 
-(* dp_apD distributes over concatenation *)
+(** dp_apD distributes over concatenation *)
 Definition dp_apD_pp (A : Type) (P : A -> Type) (f : forall a, P a)
   {a0 a1 a2 : A} (p : a0 = a1) (q : a1 = a2)
-  : dp_apD f (p @ q) = (dp_apD f p) @Dp (dp_apD f q).
+  : apD f (p @ q) = (apD f p) @Dp (apD f q).
 Proof.
   by destruct p, q.
 Defined.
 
-(* dp_apD respects inverses *)
+(** dp_apD respects inverses *)
 Definition dp_apD_V (A : Type) (P : A -> Type) (f : forall a, P a)
-  {a0 a1 : A} (p : a0 = a1) : dp_apD f p^ = (dp_apD f p)^D.
+  {a0 a1 : A} (p : a0 = a1) : apD f p^ = (apD f p)^D.
 Proof.
   by destruct p.
 Defined.
 
-(* dp_const preserves concatenation *)
+(** [dp_const] preserves concatenation *)
 Definition dp_const_pp {A B : Type} {a0 a1 a2 : A}
   {p : a0 = a1} {q : a1 = a2} {x y z : B} (r : x = y) (s : y = z)
   : dp_const (p:=p @ q) (r @ s) = (dp_const (p:=p) r) @Dp (dp_const (p:=q) s).
@@ -163,34 +127,41 @@ Proof.
   by destruct p,q.
 Defined.
 
+(** [dp_const] preserves inverses *) 
+Definition dp_const_V {A B : Type} {a0 a1 : A} {p : a0 = a1} {x y : B} (r : x = y)
+  : dp_const r^ = (dp_const (p:=p) r)^D.
+Proof.
+  by destruct p.
+Defined. 
+
 Section DGroupoid.
 
   Context {A} {P : A -> Type} {a0 a1} {p : a0 = a1}
     {b0 : P a0} {b1 : P a1} {dp : DPath P p b0 b1}.
 
   Definition dp_concat_p1
-    : DPath (fun t => DPath _ t _ _) (concat_p1 _) (dp @Dp 1) dp.
+    : DPath (fun t : a0 = a1 => DPath P t b0 b1) (concat_p1 p) (dp @Dp 1) dp.
   Proof.
     destruct p.
     apply concat_p1.
   Defined.
 
   Definition dp_concat_1p
-    : DPath (fun t => DPath _ t _ _) (concat_1p _) (1 @Dp dp) dp.
+    : DPath (fun t : a0 = a1 => DPath P t b0 b1) (concat_1p p) (1 @Dp dp) dp.
   Proof.
     destruct p.
     apply concat_1p.
   Defined.
 
   Definition dp_concat_Vp
-    : DPath (fun t => DPath _ t _ _) (concat_Vp _) (dp^D @Dp dp) 1.
+    : DPath (fun t : a1 = a1 => DPath P t b1 b1) (concat_Vp p) (dp^D @Dp dp) 1.
   Proof.
     destruct p.
     apply concat_Vp.
   Defined.
 
   Definition dp_concat_pV
-    : DPath (fun t => DPath _ t _ _) (concat_pV _) (dp @Dp dp^D) 1.
+    : DPath (fun t : a0 = a0 => DPath P t b0 b0) (concat_pV p) (dp @Dp dp^D) 1.
   Proof.
     destruct p.
     apply concat_pV.
@@ -203,7 +174,7 @@ Section DGroupoid.
        (dq : DPath P q b1 b2) (dr : DPath P  r b2 b3).
 
     Definition dp_concat_pp_p
-      : DPath (fun t => DPath _ t _ _) (concat_pp_p _ _ _)
+      : DPath (fun t : a0 = a3 => DPath P t b0 b3) (concat_pp_p p q r)
         ((dp @Dp dq) @Dp dr) (dp @Dp (dq @Dp dr)).
     Proof.
       destruct p, q, r.
@@ -211,7 +182,7 @@ Section DGroupoid.
     Defined.
 
     Definition dp_concat_p_pp
-      : DPath (fun t => DPath _ t _ _) (concat_p_pp _ _ _)
+      : DPath (fun t : a0 = a3 => DPath P t b0 b3) (concat_p_pp p q r)
         (dp @Dp (dq @Dp dr)) ((dp @Dp dq) @Dp dr).
     Proof.
       destruct p, q, r.
@@ -222,13 +193,12 @@ Section DGroupoid.
 
 End DGroupoid.
 
-(* Dependent paths over paths *)
-(* These can be found under names such as dp_paths_l akin to transport_paths_l *)
+(** Dependent paths over paths *)
+(** These can be found under names such as dp_paths_l akin to transport_paths_l *)
 
 Definition equiv_dp_paths_l {A : Type} {x1 x2 y : A} (p : x1 = x2) (q : x1 = y) r
   : p^ @ q = r <~> DPath (fun x => x = y) p q r.
 Proof.
-  refine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_l.
 Defined.
 
@@ -237,7 +207,6 @@ Notation dp_paths_l := equiv_dp_paths_l.
 Definition equiv_dp_paths_r {A : Type} {x y1 y2 : A} (p : y1 = y2) (q : x = y1) r
   :  q @ p = r <~> DPath (fun y => x = y) p q r.
 Proof.
-  refine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_r.
 Defined.
 
@@ -246,7 +215,6 @@ Notation dp_paths_r := equiv_dp_paths_r.
 Definition equiv_dp_paths_lr {A : Type} {x1 x2 : A} (p : x1 = x2) (q : x1 = x1) r
   : (p^ @ q) @ p = r <~> DPath (fun x : A => x = x) p q r.
 Proof.
-  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_lr.
 Defined.
 
@@ -255,7 +223,6 @@ Notation dp_paths_lr := equiv_dp_paths_lr.
 Definition equiv_dp_paths_Fl {A B} {f : A -> B} {x1 x2 : A} {y : B} (p : x1 = x2)
   (q : f x1 = y) r :  (ap f p)^ @ q = r <~> DPath (fun x => f x = y) p q r.
 Proof.
-  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_Fl.
 Defined.
 
@@ -264,7 +231,6 @@ Notation dp_paths_Fl := equiv_dp_paths_Fl.
 Definition equiv_dp_paths_Fr {A B} {g : A -> B} {y1 y2 : A} {x : B} (p : y1 = y2)
   (q : x = g y1) r :  q @ ap g p = r <~> DPath (fun y : A => x = g y) p q r.
 Proof.
-  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_Fr.
 Defined.
 
@@ -274,7 +240,6 @@ Definition equiv_dp_paths_FFlr {A B} {f : A -> B} {g : B -> A} {x1 x2 : A}
   (p : x1 = x2) (q : g (f x1) = x1) r
   : ((ap g (ap f p))^ @ q) @ p = r <~> DPath (fun x : A => g (f x) = x) p q r.
 Proof.
-  refine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_FFlr.
 Defined.
 
@@ -284,7 +249,6 @@ Definition equiv_dp_paths_FlFr {A B} {f g : A -> B} {x1 x2 : A} (p : x1 = x2)
   (q : f x1 = g x1) r
   : ((ap f p)^ @ q) @ ap g p = r <~> DPath (fun x : A => f x = g x) p q r.
 Proof.
-  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_FlFr.
 Defined.
 
@@ -294,7 +258,6 @@ Definition equiv_dp_paths_lFFr {A B} {f : A -> B} {g : B -> A} {x1 x2 : A}
   (p : x1 = x2) (q : x1 = g (f x1)) r
   :  (p^ @ q) @ ap g (ap f p) = r <~> DPath (fun x : A => x = g (f x)) p q r.
 Proof.
-  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_lFFr.
 Defined.
 
@@ -305,7 +268,6 @@ Definition equiv_dp_paths_FlFr_D {A B} (f g : forall a : A, B a)
   : ((apD f p)^ @ ap (transport B p) q) @ apD g p = r
     <~> DPath (fun x : A => f x = g x) p q r.
 Proof.
-  srefine (equiv_composeR' _ (Build_Equiv _ _ dp_path_transport _)).
   apply equiv_concat_l, transport_paths_FlFr_D.
 Defined.
 
@@ -329,19 +291,19 @@ Notation dp_compose := equiv_dp_compose.
 
 Definition dp_apD_compose' {A B : Type} (f : A -> B) (P : B -> Type)
            {x y : A} {p : x = y} {q : f x = f y} (r : ap f p = q) (g : forall b:B, P b)
-  : dp_apD (g o f) p = (dp_compose' f P r)^-1 (dp_apD g q).
+  : apD (g o f) p = (dp_compose' f P r)^-1 (apD g q).
 Proof.
   by destruct r, p.
 Defined.
 
 Definition dp_apD_compose {A B : Type} (f : A -> B) (P : B -> Type)
            {x y : A} (p : x = y) (g : forall b:B, P b)
-  : dp_apD (g o f) p = (dp_compose f P p)^-1 (dp_apD g (ap f p))
+  : apD (g o f) p = (dp_compose f P p)^-1 (apD g (ap f p))
   := dp_apD_compose' f P (idpath (ap f p)) g.
 
-(* Type constructors *)
+(** Type constructors *)
 
-(* Many of these lemmas exist already for transports but we prove them for
+(** Many of these lemmas exist already for transports but we prove them for
    DPaths anyway. If we change the definition of DPath to the transport,
    then these will no longer be needed. It is however, far more readable
    to keep such lemmas seperate, since it is difficult to otherwise search
@@ -349,14 +311,8 @@ Definition dp_apD_compose {A B : Type} (f : A -> B) (P : B -> Type)
 
 (** A version of [equiv_path_sigma] for [DPath]s *)
 Definition equiv_path_sigma_dp {A P} {x x' : A} {y : P x} {y' : P x'}
-  : {p : x = x' & DPath P p y y'} <~> (x; y) = (x'; y').
-Proof.
-  refine (equiv_path_sigma _ _ _ oE _).
-  apply equiv_functor_sigma_id.
-  intro p.
-  symmetry.
-  apply dp_path_transport.
-Defined.
+  : {p : x = x' & DPath P p y y'} <~> (x; y) = (x'; y')
+  := equiv_path_sigma P (x; y) (x'; y').
 
 Notation path_sigma_dp := equiv_path_sigma_dp.
 
@@ -429,13 +385,3 @@ Proof.
 Defined.
 
 Notation dp_sigma := equiv_dp_sigma.
-
-(* Useful for turning computation rules of HITs written with transports to
-   ones written with DPaths. *)
-Definition dp_apD_path_transport {A P} (f : forall a : A, P a)
-  {a0 a1 : A} (p : a0 = a1) l
-  : apD f p = dp_path_transport^-1 l -> dp_apD f p = l.
-Proof.
-  by destruct p.
-Defined.
-
diff --git a/theories/Cubical/DPathSquare.v b/theories/Cubical/DPathSquare.v
index fd33e461198..c22da884dd1 100644
--- a/theories/Cubical/DPathSquare.v
+++ b/theories/Cubical/DPathSquare.v
@@ -71,7 +71,7 @@ Notation ds_dpath := equiv_ds_dpath.
 (* We have an apD for DPathSquares *)
 Definition ds_apD {A} {B : A -> Type} (f : forall a, B a) {a00 a10 a01 a11 : A}
   {px0 : a00 = a10} {px1 : a01 = a11} {p0x p1x} (s : PathSquare px0 px1 p0x p1x)
-  : DPathSquare B s (dp_apD f px0) (dp_apD f px1) (dp_apD f p0x) (dp_apD f p1x).
+  : DPathSquare B s (apD f px0) (apD f px1) (apD f p0x) (apD f p1x).
 Proof.
   by destruct s.
 Defined.
@@ -110,7 +110,7 @@ Notation ds_const' := equiv_ds_const'.
 (* dp_apD fits into a natural square *)
 Definition dp_apD_nat {A} {P : A -> Type} {f g : forall x, P x} {x y : A}
   (q : f == g) (p : x = y)
-  : DPathSquare P (sq_refl_h _) (dp_apD f p) (dp_apD g p) (q x) (q y).
+  : DPathSquare P (sq_refl_h _) (apD f p) (apD g p) (q x) (q y).
 Proof.
   destruct p.
   by apply sq_1G.
@@ -133,7 +133,7 @@ Notation ds_G1 := equiv_ds_G1.
 Definition equiv_ds_dp {A : Type} {B : A -> Type} (f g : forall a : A, B a)
   {x1 x2 : A} (p : x1 = x2) (q1 : f x1 = g x1) (q2 : f x2 = g x2)
   : DPath (fun x : A => f x = g x) p q1 q2
-    <~> DPathSquare B (sq_refl_h p) (dp_apD f p) (dp_apD g p) q1 q2.
+    <~> DPathSquare B (sq_refl_h p) (apD f p) (apD g p) q1 q2.
 Proof.
   destruct p.
   exact sq_1G.
diff --git a/theories/Cubical/PathCube.v b/theories/Cubical/PathCube.v
index 936cf1ea55f..4918374aeab 100644
--- a/theories/Cubical/PathCube.v
+++ b/theories/Cubical/PathCube.v
@@ -358,8 +358,8 @@ Definition equiv_dp_cu {A B : Type} {x1 x2 : A} {a00 a01 a10 a11 : A -> B}
   {f1 : PathSquare (px0 x1) (px1 x1) (p0x x1) (p1x x1)}
   {f2 : PathSquare (px0 x2) (px1 x2) (p0x x2) (p1x x2)}
   {p : x1 = x2}
-  : PathCube f1 f2 (sq_dp (dp_apD px0 p)) (sq_dp (dp_apD px1 p))
-     (sq_dp (dp_apD p0x p)) (sq_dp (dp_apD p1x p))
+  : PathCube f1 f2 (sq_dp (apD px0 p)) (sq_dp (apD px1 p))
+     (sq_dp (apD p0x p)) (sq_dp (apD p1x p))
   <~> DPath (fun x => PathSquare (px0 x) (px1 x) (p0x x) (p1x x)) p f1 f2.
 Proof.
   destruct p; symmetry; exact cu_G11.
diff --git a/theories/Cubical/PathSquare.v b/theories/Cubical/PathSquare.v
index 8d8896c80f2..4e4fc83b362 100644
--- a/theories/Cubical/PathSquare.v
+++ b/theories/Cubical/PathSquare.v
@@ -595,6 +595,9 @@ Notation sq_dp := equiv_sq_dp.
 Definition sq_ap011 {A B C} (f : A -> B -> C)
   {a a' : A} (p : a = a') {b b' : B} (q : b = b')
   : PathSquare (ap (fun x => f x b) p) (ap (fun x => f x b') p)
-    (ap (f a) q) (ap (f a') q)
-  := sq_dp (dp_apD (fun y => ap (fun x => f x y) _) _).
+    (ap (f a) q) (ap (f a') q).
+Proof.
+  apply sq_dp.
+  exact (apD (fun y => ap (fun x => f x y) p) q).
+Defined.
 
diff --git a/theories/Extensions.v b/theories/Extensions.v
index cdc5da80b82..bacb14cba98 100644
--- a/theories/Extensions.v
+++ b/theories/Extensions.v
@@ -102,7 +102,7 @@ Section Extensions.
       - size of C
       - size of result (>= A,B,C) *)
 
-  Global Arguments ExtendableAlong n%nat_scope {A B}%type_scope (f C)%function_scope.
+  Global Arguments ExtendableAlong n%_nat_scope {A B}%_type_scope (f C)%_function_scope.
 
   (** We can modify the universes, as with [ExtensionAlong]. *)
   Definition lift_extendablealong@{a1 a2 amin b1 b2 bmin p1 p2 pmin m1 m2}
@@ -324,7 +324,7 @@ Section Extensions.
     := forall n : nat, ExtendableAlong@{i j k l} n f C.
   (** Universe parameters are the same as for [ExtendableAlong]. *)
 
-  Global Arguments ooExtendableAlong {A B}%type_scope (f C)%function_scope.
+  Global Arguments ooExtendableAlong {A B}%_type_scope (f C)%_function_scope.
 
   (** Universe modification. *)
   Definition lift_ooextendablealong@{a1 a2 amin b1 b2 bmin p1 p2 pmin m1 m2}
@@ -440,9 +440,9 @@ Definition cyl_extension {A B} (f : A -> B) (C : Cyl f -> Type)
            (ext : ExtensionAlong cyl C g)
   : ExtensionAlong cyl C g.
 Proof.
-  srefine (Cyl_ind_dp C g (ext.1 o cyr) _ ; _); intros a.
+  srefine (Cyl_ind C g (ext.1 o cyr) _ ; _); intros a.
   + refine ((ext.2 a)^ @Dl _)%dpath.
-    apply dp_apD.
+    apply apD.
   + reflexivity. (** The point is that this equality is now definitional. *)
 Defined.
 
@@ -725,13 +725,12 @@ Proof.
         - rapply extendable_equiv.
         - exact (eh (fun x => cglue x # u (cyr x)) (v o cyr)). }
     intros x; subst C'.
-    refine (_ oE dp_path_transport).
     refine ((dp_compose (pr_cylcoeq p q) C _)^-1 oE _).
     symmetry; srapply equiv_ds_fill_lr.
     3:rapply ap_pr_cylcoeq_cglue.
     all:srapply (transport (fun r => DPath C r _ _)).
-    3:exact (dp_inverse (dp_compose _ C _ (dp_apD u (eissect pr_cyl x)))).
-    4:exact (dp_inverse (dp_compose _ C _ (dp_apD v (eissect pr_cyl x)))).
+    3:exact (dp_inverse (dp_compose _ C _ (apD u (eissect pr_cyl x) : DPath _ _ _ _))).
+    4:exact (dp_inverse (dp_compose _ C _ (apD v (eissect pr_cyl x) : DPath _ _ _ _))).
     1:change (fun y => pr_cylcoeq p q (coeq (functor_cyl p y)))
       with (fun y => coeq (f := f') (g := g') (pr_cyl (functor_cyl p y))).
     2:change (fun y => pr_cylcoeq p q (coeq (functor_cyl q y)))
@@ -740,11 +739,11 @@ Proof.
     all: exact (ap_compose (fun x => pr_cyl (functor_cyl _ x)) coeq _). }
   pose (eb1 := fun u v w => (fst (cyl_extendable _ _ _ (eb'' u v)) w).1).
   (** Now we construct an extension using Coeq-induction, and prove that it *is* an extension also using Coeq-induction. *)
-  srefine (_;_); srapply Coeq_ind_dp.
+  srefine (_;_); srapply Coeq_ind.
   + exact (ea1 (s' o coeq)).
   + apply eb1; intros b.
     rapply (dp_compose' _ _ (ap_cyl_cylcoeq_cglue p q b)).
-    exact (dp_apD s' (cglue b)).
+    exact (apD s' (cglue b)).
   + (** Since we're using cofibrations, this holds definitionally. *)
     intros a; reflexivity.
   + (** And this one is much simpler than it would be otherwise. *)
@@ -753,7 +752,7 @@ Proof.
     rapply ds_G1.
     refine (dp_apD_compose' _ _ (ap_cyl_cylcoeq_cglue p q b) _ @ _).
     apply moveR_equiv_V.
-    rapply (Coeq_ind_dp_beta_cglue C').
+    nrapply Coeq_ind_beta_cglue.
 Defined.
 
 (** Now we can easily iterate into higher extendability. *)
diff --git a/theories/HIT/V.v b/theories/HIT/V.v
index 52a30dbc0cd..3edc673424e 100644
--- a/theories/HIT/V.v
+++ b/theories/HIT/V.v
@@ -389,7 +389,7 @@ Lemma monic_set_present : forall u : V, exists (Au : Type) (m : Au -> V),
 Proof.
   apply V_ind_hprop.
   - intros A f _.
-    destruct (quotient_kernel_factor f (ker_bisim f) (ker_bisim_is_ker f))
+    destruct (quotient_kernel_factor_general f (ker_bisim f) (ker_bisim_is_ker f))
       as [Au [eu [mu (((hset_Au, epi_eu), mono_mu), factor)]]].
     exists Au, mu. split;[exact (hset_Au, mono_mu)|].
     apply setext'; split.
diff --git a/theories/HIT/iso.v b/theories/HIT/iso.v
index 090eb2abc6a..c3f4cf3fcd0 100644
--- a/theories/HIT/iso.v
+++ b/theories/HIT/iso.v
@@ -11,14 +11,12 @@ Section iso.
   Variables X Y : HSet.
   Variable f : X -> Y.
 
-  Lemma atmost1P_isinj (injf : isinj f)
+  Lemma atmost1P_isinj (injf : IsInjective f)
   : forall y : Y, atmost1P (fun x => f x = y).
   Proof.
-    unfold isinj, atmost1P in *.
-    intros.
-    apply injf.
-    path_induction.
-    reflexivity.
+    intros y x x' p q.
+    apply (injective f).
+    exact (p @ q^).
   Defined.
 
   Definition isequiv_isepi_ismono (epif : isepi f) (monof : ismono f)
diff --git a/theories/HIT/quotient.v b/theories/HIT/quotient.v
index b42e68a37d9..428e05ffc50 100644
--- a/theories/HIT/quotient.v
+++ b/theories/HIT/quotient.v
@@ -5,7 +5,7 @@ Require Import Truncations.Core.
 
 Local Open Scope path_scope.
 
-(** * Quotient of a Type by an hprop-valued relation
+(** * The set-quotient of a type by an hprop-valued relation
 
 We aim to model:
 <<
@@ -16,23 +16,23 @@ Inductive quotient : Type :=
 >>
 *)
 
-(** This development should be further connected with the sections in the book; see below.*)
+(** TODO:  This development should be further connected with the sections in the book; see below.  And it should be merged with Colimits.Quotient. Currently this file is only used in Classes/implementations/natpair_integers.v and Classes/implementations/field_of_fractions.v, so it shouldn't be too hard to switch to Colimits.Quotient. *)
 
 Module Export Quotient.
 
   Section Domain.
 
-    Context {A : Type} (R : Relation A) {sR: is_mere_relation _ R}.
+    Universes i j u.
+    Constraint i <= u, j <= u.
+
+    Context {A : Type@{i}} (R : Relation@{i j} A) {sR: is_mere_relation _ R}.
 
     (** We choose to let the definition of quotient depend on the proof that [R] is a set-relations.  Alternatively, we could have defined it for all relations and only develop the theory for set-relations.  The former seems more natural.
 
 We do not require [R] to be an equivalence relation, but implicitly consider its transitive-reflexive closure. *)
 
-
-    (** Note: If we wanted to be really accurate, we'd need to put [@quotient A R sr] in the max [U_{sup(i, j)}] of the universes of [A : U_i] and [R : A -> A -> U_j].  But this requires some hacky code, at the moment, and the only thing we gain is avoiding making use of an implicit hpropositional resizing "axiom". *)
-
     (** This definition has a parameter [sR] that shadows the ambient one in the Context in order to ensure that it actually ends up depending on everything in the Context when the section is closed, since its definition doesn't actually refer to any of them.  *)
-    Private Inductive quotient {sR: is_mere_relation _ R} : Type :=
+    Private Inductive quotient {sR: is_mere_relation _ R} : Type@{u} :=
     | class_of : A -> quotient.
 
     (** The path constructors. *)
diff --git a/theories/HIT/surjective_factor.v b/theories/HIT/surjective_factor.v
index 21c46c02112..d3b0d5c46cd 100644
--- a/theories/HIT/surjective_factor.v
+++ b/theories/HIT/surjective_factor.v
@@ -1,5 +1,4 @@
 Require Import
-        HoTT.Types
         HoTT.Basics
         HoTT.Truncations.Core Modalities.Modality.
 
diff --git a/theories/HSet.v b/theories/HSet.v
index 27450f4b126..def22d820ab 100644
--- a/theories/HSet.v
+++ b/theories/HSet.v
@@ -1,6 +1,6 @@
 (* -*- mode: coq; mode: visual-line -*-  *)
 Require Import Basics.
-Require Import Types.Sigma Types.Forall Types.Paths Types.Unit Types.Arrow.
+Require Import Types.Sigma Types.Paths Types.Unit Types.Arrow.
 
 (** * H-Sets *)
 
@@ -108,11 +108,8 @@ Definition ismono {X Y} (f : X -> Y)
   := forall (Z : HSet),
      forall g h : Z -> X, f o g = f o h -> g = h.
 
-Definition isinj {X Y} (f : X -> Y)
-  := forall x0 x1 : X,
-       f x0 = f x1 -> x0 = x1.
-
-Lemma isinj_embedding {A B : Type} (m : A -> B) : IsEmbedding m -> isinj m.
+Global Instance isinj_embedding {A B : Type} (m : A -> B)
+  : IsEmbedding m -> IsInjective m.
 Proof.
   intros ise x y p.
   pose (ise (m y)).
@@ -128,14 +125,14 @@ Proof.
 Defined.
 
 Definition isinj_section {A B : Type} {s : A -> B} {r : B -> A}
-      (H : r o s == idmap) : isinj s.
+      (H : r o s == idmap) : IsInjective s.
 Proof.
   intros a a' alpha.
   exact ((H a)^ @ ap r alpha @ H a').
 Defined.
 
 Lemma isembedding_isinj_hset {A B : Type} `{IsHSet B} (m : A -> B)
-: isinj m -> IsEmbedding m.
+: IsInjective m -> IsEmbedding m.
 Proof.
   intros isi b.
   apply hprop_allpath; intros [x p] [y q].
@@ -143,7 +140,7 @@ Proof.
   exact (isi x y (p @ q^)).
 Defined.
 
-Lemma ismono_isinj `{Funext} {X Y} (f : X -> Y) : isinj f -> ismono f.
+Lemma ismono_isinj `{Funext} {X Y} (f : X -> Y) : IsInjective f -> ismono f.
 Proof.
   intros ? ? ? ? H'.
   apply path_forall.
@@ -154,7 +151,7 @@ Qed.
 
 Definition isinj_ismono {X Y} (f : X -> Y)
            (H : ismono f)
-: isinj f
+: IsInjective f
   := fun x0 x1 H' =>
        ap10 (H (Build_HSet Unit)
                (fun _ => x0)
@@ -176,18 +173,9 @@ Proof.
     * by rewrite eissect.
 Qed.
 
-Lemma cancelL_isinjective {A B C : Type} {f : A -> B} {g : B -> C} `{I : isinj (g o f)}
-  : isinj f.
-Proof.
-  intros a0 a1 p.
-  apply I.
-  exact (ap g p).
-Defined.
-
 Lemma cancelL_isembedding {A B C : Type} `{IsHSet B} {f : A -> B} {g : B -> C} `{IsEmbedding (g o f)}
   : IsEmbedding f.
 Proof.
-  apply isembedding_isinj_hset.
-  rapply (cancelL_isinjective (g:=g)).
-  rapply isinj_embedding.
+  rapply isembedding_isinj_hset.
+  rapply (isinj_cancelL _ g).
 Defined.
diff --git a/theories/HoTT.v b/theories/HoTT.v
index d5194384764..02e53a75dc2 100644
--- a/theories/HoTT.v
+++ b/theories/HoTT.v
@@ -100,10 +100,12 @@ Require Export HoTT.Modalities.Meet.
 Require Export HoTT.Modalities.CoreflectiveSubuniverse.
 
 Require Export HoTT.Spaces.Nat.
-Require Export HoTT.Spaces.Int.
+Require Export HoTT.Spaces.BinInt.
 Require Export HoTT.Spaces.Pos.
 
-Require Export HoTT.Spaces.List.
+Require Export HoTT.Spaces.List.Core.
+Require Export HoTT.Spaces.List.Theory.
+Require Export HoTT.Spaces.List.Paths.
 
 Require Export HoTT.Spaces.Cantor.
 
diff --git a/theories/Homotopy/Bouquet.v b/theories/Homotopy/Bouquet.v
index c1b4d3660bb..3fa612194d9 100644
--- a/theories/Homotopy/Bouquet.v
+++ b/theories/Homotopy/Bouquet.v
@@ -23,8 +23,6 @@ Section AssumeUnivalence.
     : IsConnected 0 (Bouquet S).
   Proof.
     rapply isconnected_susp.
-    rapply contr_inhabited_hprop.
-    exact (tr pt).
   Defined.
 
   (** We can directly prove that it satisfies the desired equivalence together with naturality in the second argument. *)
@@ -38,7 +36,7 @@ Section AssumeUnivalence.
     1: refine (natequiv_prewhisker (natequiv_pointify_r S) ptype_group).
     (** Post-compose with [pequiv_loops_bg_g] *)
     nrefine (natequiv_compose _ _).
-1: rapply (natequiv_postwhisker _ (natequiv_inverse natequiv_g_loops_bg)).
+    1: rapply (natequiv_postwhisker _ (natequiv_inverse natequiv_g_loops_bg)).
     (** Loop-susp adjoint *)
     nrefine (natequiv_compose _ _).
     1: refine (natequiv_prewhisker
diff --git a/theories/Homotopy/CayleyDickson.v b/theories/Homotopy/CayleyDickson.v
index 16855a735e4..9bae2ba3106 100644
--- a/theories/Homotopy/CayleyDickson.v
+++ b/theories/Homotopy/CayleyDickson.v
@@ -102,7 +102,7 @@ Class CayleyDicksonImaginaroid (A : Type) := {
 Global Instance involutive_negate_susp {A} `(CayleyDicksonImaginaroid A)
   : Involutive (negate_susp A cdi_negate).
 Proof.
-  srapply Susp_ind_dp; try reflexivity.
+  srapply Susp_ind; try reflexivity.
   intro x.
   apply dp_paths_FFlr.
   rewrite concat_p1.
@@ -117,7 +117,7 @@ Defined.
 Global Instance involutive_conjugate_susp {A} `(CayleyDicksonImaginaroid A)
   : Involutive (conjugate_susp A cdi_negate).
 Proof.
-  srapply Susp_ind_dp; try reflexivity.
+  srapply Susp_ind; try reflexivity.
   intro x.
   apply dp_paths_FFlr.
   rewrite concat_p1.
@@ -134,7 +134,7 @@ Defined.
 Global Instance swapop_conjugate_susp {A} `(CayleyDicksonImaginaroid A)
   : SwapOp negate (conjugate_susp A cdi_negate).
 Proof.
-  srapply Susp_ind_dp; try reflexivity.
+  srapply Susp_ind; try reflexivity.
   intro x.
   apply dp_paths_FlFr.
   rewrite concat_p1.
@@ -272,11 +272,11 @@ Section ImaginaroidHSpace.
         apply jglue. }
     intros a b.
     revert y.
-    srapply Join_ind_dp.
+    srapply Join_ind.
     1: intro; apply jglue.
     1: intro; cbn; symmetry; apply jglue.
     intros c d.
-    srapply sq_dp^-1.
+    apply sq_dp^-1.
     refine (sq_ccGG _^ _^ _).
     1,2: apply Join_rec_beta_jglue.
     change (PathSquare (jglue (a * c) (c * b)) (jglue ((- d) * conj b) (conj a * d))^
@@ -294,7 +294,7 @@ Section ImaginaroidHSpace.
     clear a b c d.
     change (forall s : Susp A,
       Diamond (-mon_unit) s (mon_unit) s).
-    srapply Susp_ind_dp; hnf.
+    srapply Susp_ind; hnf.
     1: by apply diamond_v_sq.
     1: by apply diamond_h_sq.
     intro a.
diff --git a/theories/Homotopy/ClassifyingSpace.v b/theories/Homotopy/ClassifyingSpace.v
index 07990c98c08..7fdf896df43 100644
--- a/theories/Homotopy/ClassifyingSpace.v
+++ b/theories/Homotopy/ClassifyingSpace.v
@@ -12,9 +12,6 @@ Local Open Scope mc_scope.
 Local Open Scope trunc_scope.
 Local Open Scope mc_mult_scope.
 
-Declare Scope bg_scope.
-Local Open Scope bg_scope.
-
 (** * We define the Classifying space of a group to be the following HIT:
 
   HIT ClassifyingSpace (G : Group) : 1-Type
@@ -74,7 +71,7 @@ Module Export ClassifyingSpace.
       (bloop_pp' : forall x y,  DPathSquare P (sq_G1 (bloop_pp x y))
         (bloop' (x * y)) ((bloop' x) @Dp (bloop' y)) 1 1)
       (x : G)
-      : dp_apD (ClassifyingSpace_ind P bbase' bloop' bloop_pp') (bloop x) = bloop' x.
+      : apD (ClassifyingSpace_ind P bbase' bloop' bloop_pp') (bloop x) = bloop' x.
     Proof. Admitted.
 
   End ClassifyingSpace_ind.
@@ -123,8 +120,8 @@ Section Eliminators.
   Proof.
     refine (ClassifyingSpace_ind P bbase' bloop' _).
     intros.
-    apply ds_G1, dp_path_transport.
-    srapply path_ishprop.
+    apply ds_G1. 
+    apply path_ishprop.
   Defined.
 
   Definition ClassifyingSpace_rec_hset
@@ -318,12 +315,16 @@ Section EncodeDecode.
 
   (* We also record this fact. *)
   Definition grp_homo_loops {X Y : pType} `{IsTrunc 1 X} `{IsTrunc 1 Y}
-             (f : X ->* Y)
-    : LoopGroup X $-> LoopGroup Y.
+    : (X ->** Y) ->* [LoopGroup X $-> LoopGroup Y, grp_homo_const].
   Proof.
-    snrapply Build_GroupHomomorphism.
-    - exact (fmap loops f).
-    - nrapply fmap_loops_pp.
+    snrapply Build_pMap.
+    - intro f.
+      snrapply Build_GroupHomomorphism.
+      + exact (fmap loops f).
+      + nrapply fmap_loops_pp.
+    - cbn beta.
+      apply equiv_path_grouphomomorphism.
+      exact (pointed_htpy fmap_loops_pconst).
   Defined.
 
 End EncodeDecode.
@@ -373,8 +374,9 @@ Section HSpace_bg.
     snrapply ClassifyingSpace_ind_hprop.
     1: exact _.
     simpl.
-    apply sq_dp^-1, sq_1G.
-    refine (_ @ (ap_idmap _)^).
+    nrapply (transport_paths_FFlr' (g := idmap)).
+    apply equiv_p1_1q.
+    lhs nrapply ap_idmap.
     nrapply ClassifyingSpace_rec_beta_bloop.
   Defined.
 
@@ -430,6 +432,7 @@ Definition natequiv_g_loops_bg `{Univalence}
 Proof.
   snrapply Build_NatEquiv.
   1: intros G; rapply pequiv_g_loops_bg.
+  snrapply Build_Is1Natural.
   intros X Y f.
   symmetry.
   apply pbloop_natural.
@@ -531,6 +534,7 @@ Defined.
 Global Instance is1natural_grp_homo_pmap_bg_r {U : Univalence} (G : Group)
   : Is1Natural (opyon G) (opyon (B G) o B) (equiv_grp_homo_pmap_bg G).
 Proof.
+  snrapply Build_Is1Natural.
   intros K H f h.
   apply path_hom.
   rapply (fmap_comp B h f).
diff --git a/theories/Homotopy/EMSpace.v b/theories/Homotopy/EMSpace.v
index a2f366558e2..b433d8e5306 100644
--- a/theories/Homotopy/EMSpace.v
+++ b/theories/Homotopy/EMSpace.v
@@ -4,19 +4,16 @@ Require Import Cubical.DPath.
 Require Import Algebra.AbGroups.
 Require Import Homotopy.Suspension.
 Require Import Homotopy.ClassifyingSpace.
-Require Import Homotopy.HSpace.Core.
 Require Import Homotopy.HSpace.Coherent.
 Require Import Homotopy.HomotopyGroup.
 Require Import Homotopy.Hopf.
-Require Import TruncType.
 Require Import Truncations.Core Truncations.Connectedness.
 Require Import WildCat.
 
-(* Formalisation of Eilenberg-MacLane spaces *)
+(** * Eilenberg-Mac Lane spaces *)
 
 Local Open Scope pointed_scope.
 Local Open Scope nat_scope.
-Local Open Scope bg_scope.
 Local Open Scope mc_mult_scope.
 
 (** The definition of the Eilenberg-Mac Lane spaces.  Note that while we allow [G] to be non-abelian for [n > 1], later results will need to assume that [G] is abelian. *)
@@ -37,12 +34,21 @@ Section EilenbergMacLane.
     destruct n as [|[]]; exact _.
   Defined.
 
+  (** This is subsumed by the next result, but Coq doesn't always find the next result when it should. *)
   Global Instance isconnected_em {G : Group} (n : nat)
     : IsConnected n K(G, n.+1).
   Proof.
     induction n; exact _.
   Defined.
 
+  Global Instance isconnected_em' {G : Group} (n : nat)
+    : IsConnected n.-1 K(G, n).
+  Proof.
+    destruct n.
+    1: exact (is_minus_one_connected_pointed _).
+    apply isconnected_em.
+  Defined.
+
   Global Instance is0connected_em {G : Group} (n : nat)
     : IsConnected 0 K(G, n.+1).
   Proof.
@@ -51,7 +57,7 @@ Section EilenbergMacLane.
 
   Local Open Scope trunc_scope.
 
-  (* This is a variant of [pequiv_ptr_loop_psusp] from pSusp.v. All we are really using is that [n.+2 <= n +2+ n], but because of the use of [isconnmap_pred_add], the proof is a bit more specific to this case. *)
+  (** This is a variant of [pequiv_ptr_loop_psusp] from pSusp.v. All we are really using is that [n.+2 <= n +2+ n], but because of the use of [isconnmap_pred_add], the proof is a bit more specific to this case. *)
   Local Lemma pequiv_ptr_loop_psusp' (X : pType) (n : nat) `{IsConnected n.+1 X}
     : pTr n.+2 X <~>* pTr n.+2 (loops (psusp X)).
   Proof.
@@ -85,7 +91,7 @@ Section EilenbergMacLane.
       exact (emap (iterated_loops n) (pequiv_loops_em_em _ _)).
   Defined.
 
-  (* For positive indices, we in fact get a group isomorphism. *)
+  (** For positive indices, we in fact get a group isomorphism. *)
   Definition equiv_g_pi_n_em (G : AbGroup) (n : nat)
     : GroupIsomorphism G (Pi n.+1 K(G, n.+1)).
   Proof.
@@ -104,4 +110,39 @@ Section EilenbergMacLane.
     apply iscohhspace_loops.
   Defined.
 
+  (** If [G] and [G'] are isomorphic, then [K(G,n)] and [K(G',n)] are equivalent.  TODO:  We should show that [K(-,n)] is a functor, which implies this. *)
+  Definition pequiv_em_group_iso {G G' : Group} (n : nat)
+    (e : G $<~> G')
+    : K(G, n) <~>* K(G', n).
+  Proof.
+    by destruct (equiv_path_group e).
+  Defined.
+
+  (** Every pointed (n-1)-connected n-type is an Eilenberg-Mac Lane space. *)
+  Definition pequiv_em_connected_truncated (X : pType)
+    (n : nat) `{IsConnected n X} `{IsTrunc n.+1 X}
+    : K(Pi n.+1 X, n.+1) <~>* X.
+  Proof.
+    generalize dependent X; induction n; intros X isC isT.
+    1: rapply pequiv_pclassifyingspace_pi1.
+    (* The equivalence will be the composite
+<<
+      K( (Pi n.+2 X) n.+2)
+   <~>* K( (Pi n.+1 (loops X)), n.+2)
+   = pTr n.+2 (psusp K( (Pi n.+1 (loops X)), n.+1))  [by definition]
+   <~>* pTr n.+2 (psusp (loops X))
+   <~>* pTr n.+2 X
+   <~>* X
+>>
+    and we'll work from right to left.
+*)
+    refine ((pequiv_ptr (n:=n.+2))^-1* o*E _).
+    refine (pequiv_ptr_psusp_loops X n o*E _).
+    change (K(?G, n.+2)) with (pTr n.+2 (psusp K( G, n.+1 ))).
+    refine (emap (pTr n.+2 o psusp) _).
+    refine ((IHn (loops X) _ _) o*E _).
+    apply pequiv_em_group_iso.
+    apply groupiso_pi_loops.
+  Defined.
+
 End EilenbergMacLane.
diff --git a/theories/Homotopy/HSpace/Coherent.v b/theories/Homotopy/HSpace/Coherent.v
index d2899cb8a47..4331f1eac49 100644
--- a/theories/Homotopy/HSpace/Coherent.v
+++ b/theories/Homotopy/HSpace/Coherent.v
@@ -21,13 +21,8 @@ Definition issig_iscohhspace (A : pType)
     & { hspace_left_identity : LeftIdentity hspace_op pt
     & { hspace_right_identity : RightIdentity hspace_op pt
     & hspace_left_identity pt = hspace_right_identity pt } } }
-      <~> IsCohHSpace A.
-Proof.
-  transitivity { H : IsHSpace A & IsCoherent A }.
-  2: issig.
-  unfold IsCoherent.
-  make_equiv.
-Defined.
+      <~> IsCohHSpace A
+  := ltac:(make_equiv).
 
 (** A type equivalent to a coherent H-space is a coherent H-space. *)
 Definition iscohhspace_equiv_cohhspace {X Y : pType} `{IsCohHSpace Y} (f : X <~>* Y)
diff --git a/theories/Homotopy/HSpaceS1.v b/theories/Homotopy/HSpaceS1.v
index 6a428ecf6d8..d4d8b9f7d95 100644
--- a/theories/Homotopy/HSpaceS1.v
+++ b/theories/Homotopy/HSpaceS1.v
@@ -21,7 +21,6 @@ Section HSpace_S1.
     srapply Susp_ind; hnf.
     { apply moveL_transport_p.
       refine ((transport_pp _ _ _ _)^ @ _).
-      apply dp_path_transport^-1.
       apply p. }
     1: reflexivity.
     apply Empty_ind.
@@ -101,8 +100,7 @@ Section HSpace_S1.
     { apply (sq_flip_v (px0:=1) (px1:=1)).
       exact (ap_nat' (fun a => ap (fun b => sgop_s1 b z)
         (rightidentity_s1 a)) (merid North @ (merid South)^)). }
-    simpl.
-    srapply dp_ishprop.
+    apply path_ishprop.
   Defined.
 
   Global Instance commutative_sgop_s1
diff --git a/theories/Homotopy/Hopf.v b/theories/Homotopy/Hopf.v
index b01bb22fc25..16da9f43743 100644
--- a/theories/Homotopy/Hopf.v
+++ b/theories/Homotopy/Hopf.v
@@ -176,3 +176,15 @@ Proof.
     + nrapply (isconnected_equiv' _ _ (pequiv_pfiber_loops_susp_counit_join X)^-1).
       nrapply isconnected_join; exact _.
 Defined.
+
+(** In particular, we get the following result.  All we are really using is that [n.+2 <= n +2+ n], but because of the use of [isconnmap_pred_add], the proof is a bit more specific to this case. *)
+Definition pequiv_ptr_psusp_loops `{Univalence} (X : pType) (n : nat) `{IsConnected n.+1 X}
+  : pTr n.+2 (psusp (loops X)) <~>* pTr n.+2 X.
+Proof.
+  snrapply Build_pEquiv.
+  1: rapply (fmap (pTr _) (loop_susp_counit _)).
+  nrapply O_inverts_conn_map.
+  nrapply (isconnmap_pred_add n.-2).
+  rewrite 2 trunc_index_add_succ.
+  rapply (conn_map_loop_susp_counit X).
+Defined.
diff --git a/theories/Homotopy/Join/Core.v b/theories/Homotopy/Join/Core.v
index 1d76ad8990f..c6c480aa472 100644
--- a/theories/Homotopy/Join/Core.v
+++ b/theories/Homotopy/Join/Core.v
@@ -42,27 +42,6 @@ Section Join.
     : apD (Join_ind P P_A P_B P_g) (jglue a b) = P_g a b
     := Pushout_ind_beta_pglue _ _ _ _ _.
 
-  (** A version of [Join_ind] that uses dependant paths. *)
-  Definition Join_ind_dp {A B : Type} (P : Join A B -> Type)
-    (P_A : forall a, P (joinl a)) (P_B : forall b, P (joinr b))
-    (P_g : forall a b, DPath P (jglue a b) (P_A a) (P_B b))
-    : forall (x : Join A B), P x.
-  Proof.
-    refine (Join_ind P P_A P_B _).
-    intros a b.
-    apply dp_path_transport^-1.
-    exact (P_g a b).
-  Defined.
-
-  Definition Join_ind_dp_beta_jglue {A B : Type} (P : Join A B -> Type)
-    (P_A : forall a, P (joinl a)) (P_B : forall b, P (joinr b))
-    (P_g : forall a b, DPath P (jglue a b) (P_A a) (P_B b)) a b
-    : dp_apD (Join_ind_dp P P_A P_B P_g) (jglue a b) = P_g a b.
-  Proof.
-    apply dp_apD_path_transport.
-    snrapply Join_ind_beta_jglue.
-  Defined.
-
   (** A version of [Join_ind] specifically for proving that two functions defined on a [Join] are homotopic. *)
   Definition Join_ind_FlFr {A B P : Type} (f g : Join A B -> P)
     (Hl : forall a, f (joinl a) = g (joinl a))
@@ -113,8 +92,8 @@ Section Join.
 
 End Join.
 
-Arguments joinl {A B}%type_scope _ , [A] B _.
-Arguments joinr {A B}%type_scope _ , A [B] _.
+Arguments joinl {A B}%_type_scope _ , [A] B _.
+Arguments joinr {A B}%_type_scope _ , A [B] _.
 
 (** * [Join_rec] gives an equivalence of 0-groupoids
 
@@ -127,11 +106,11 @@ Record JoinRecData {A B P : Type} := {
   }.
 
 Arguments JoinRecData : clear implicits.
-Arguments Build_JoinRecData {A B P}%type_scope (jl jr jg)%function_scope.
+Arguments Build_JoinRecData {A B P}%_type_scope (jl jr jg)%_function_scope.
 
 (** We use the name [join_rec] for the version of [Join_rec] defined on this data. *)
 Definition join_rec {A B P : Type} (f : JoinRecData A B P)
-  : Join A B -> P
+  : Join A B $-> P
   := Join_rec (jl f) (jr f) (jg f).
 
 Definition join_rec_beta_jg {A B P : Type} (f : JoinRecData A B P) (a : A) (b : B)
@@ -581,16 +560,24 @@ Section FunctorJoin.
   Definition equiv_functor_join {A B C D} (f : A <~> C) (g : B <~> D)
     : Join A B <~> Join C D := Build_Equiv _ _ (functor_join f g) _.
 
-  Global Instance isbifunctor_join : IsBifunctor Join.
+  Global Instance is0bifunctor_join : Is0Bifunctor Join.
+  Proof.
+    snrapply Build_Is0Bifunctor'.
+    1,2: exact _.
+    apply Build_Is0Functor.
+    intros A B [f g].
+    exact (functor_join f g).
+  Defined.
+
+  Global Instance is1bifunctor_join : Is1Bifunctor Join.
   Proof.
-    snrapply Build_IsBifunctor.
-    - intro A; snrapply Build_Is0Functor; intros B D g.
-      exact (functor_join idmap g).
-    - intro B; snrapply Build_Is0Functor; intros A C f.
-      exact (functor_join f idmap).
-    - intros A C f B D g x.
-      lhs_V nrapply functor_join_compose.
-      nrapply functor_join_compose.
+    snrapply Build_Is1Bifunctor'.
+    nrapply Build_Is1Functor.
+    - intros A B f g [p q].
+      exact (functor2_join p q).
+    - intros A; exact functor_join_idmap.
+    - intros A B C [f g] [h k].
+      exact (functor_join_compose f g h k).
   Defined.
 
 End FunctorJoin.
@@ -640,7 +627,8 @@ Section JoinSym.
       1, 2: apply joinrecdata_sym.
       1, 2: apply joinrecdata_sym_inv.
     (* Naturality: *)
-    - intros P Q g f; simpl.
+    - snrapply Build_Is1Natural.
+      intros P Q g f; simpl.
       bundle_joinrecpath.
       intros b a; simpl.
       symmetry; apply ap_V.
@@ -845,11 +833,12 @@ Section JoinEmpty.
   Definition equiv_join_empty_left A : Join Empty A <~> A
     := equiv_join_empty_right _ oE equiv_join_sym _ _.
 
-  Global Instance join_right_unitor : RightUnitor Type Join Empty.
+  Global Instance join_right_unitor : RightUnitor Join Empty.
   Proof.
     snrapply Build_NatEquiv.
     - apply equiv_join_empty_right.
-    - intros A B f.
+    - snrapply Build_Is1Natural.
+      intros A B f.
       cbn -[equiv_join_empty_right].
       snrapply Join_ind_FlFr.
       + intro a.
@@ -858,11 +847,12 @@ Section JoinEmpty.
       + intros a [].
   Defined.
 
-  Global Instance join_left_unitor : LeftUnitor Type Join Empty.
+  Global Instance join_left_unitor : LeftUnitor Join Empty.
   Proof.
     snrapply Build_NatEquiv.
     - apply equiv_join_empty_left.
-    - intros A B f x.
+    - snrapply Build_Is1Natural.
+      intros A B f x.
       cbn -[equiv_join_empty_right].
       rhs_V rapply (isnat_natequiv join_right_unitor).
       cbn -[equiv_join_empty_right].
diff --git a/theories/Homotopy/Join/JoinAssoc.v b/theories/Homotopy/Join/JoinAssoc.v
index 1a50b7f617d..19f07ae8c4b 100644
--- a/theories/Homotopy/Join/JoinAssoc.v
+++ b/theories/Homotopy/Join/JoinAssoc.v
@@ -60,7 +60,8 @@ Proof.
     1, 2: apply trijoinrecdata_twist.
     1, 2: apply trijoinrecdata_twist_inv.
   (* Naturality: *)
-  - intros P Q g f; simpl.
+  - snrapply Build_Is1Natural.
+    intros P Q g f; simpl.
     bundle_trijoinrecpath.
     all: intros; cbn.
     + symmetry; apply ap_V.
@@ -260,25 +261,13 @@ Proof.
   apply trijoin_id_sym_nat.
 Defined.
 
-Global Instance join_associator : Associator Type Join.
+Global Instance join_associator : Associator Join.
 Proof.
-  unshelve econstructor; unfold right_assoc, left_assoc, uncurry; cbn.
-  - intros [[A B] C]; cbn.
-    apply join_assoc.
-  - intros [[A B] C] [[A' B'] C'] [[f g] h]; cbn.
-    (* This is awkward because Monoidal.v works with a tensor that is separately a functor in each variable. *)
-    intro x.
-    rhs_V nrapply functor_join_compose.
-    rhs_V nrapply functor2_join.
-    2: reflexivity.
-    2: nrapply functor_join_compose.
-    cbn.
-    rhs_V nrapply join_assoc_nat; cbn.
-    apply ap.
-    lhs_V nrapply functor_join_compose.
-    apply functor2_join.
-    1: reflexivity.
-    symmetry; nrapply functor_join_compose.
+  snrapply Build_Associator; simpl.
+  - exact join_assoc.
+  - snrapply Build_Is1Natural.
+    intros [[A B] C] [[A' B'] C'] [[f g] h]; cbn.
+    apply join_assoc_nat.
 Defined.
 
 (** ** The Triangle Law *)
@@ -310,9 +299,9 @@ Proof.
     apply join_sym_beta_jglue.
 Defined.
 
-Definition join_trianglelaw A B : TriangleLaw Type Join Empty A B.
+Definition join_trianglelaw : TriangleIdentity Join Empty.
 Proof.
-  unfold TriangleLaw; intro x; cbn.
+  intros A B x; cbn. 
   lhs nrapply (functor_join_compose idmap _ idmap _).
   lhs_V nrapply join_trianglelaw'.
   unfold join_assoc; cbn.
diff --git a/theories/Homotopy/Join/TriJoin.v b/theories/Homotopy/Join/TriJoin.v
index 9fb73a99e27..52bab840645 100644
--- a/theories/Homotopy/Join/TriJoin.v
+++ b/theories/Homotopy/Join/TriJoin.v
@@ -156,10 +156,10 @@ Record TriJoinRecData {A B C P : Type} := {
   }.
 
 Arguments TriJoinRecData : clear implicits.
-Arguments Build_TriJoinRecData {A B C P}%type_scope (j1 j2 j3 j12 j13 j23 j123)%function_scope.
+Arguments Build_TriJoinRecData {A B C P}%_type_scope (j1 j2 j3 j12 j13 j23 j123)%_function_scope.
 
 Definition trijoin_rec {A B C P : Type} (f : TriJoinRecData A B C P)
-  : TriJoin A B C -> P.
+  : TriJoin A B C $-> P.
 Proof.
   snrapply Join_rec.
   - exact (j1 f).
@@ -297,8 +297,8 @@ Record TriJoinRecData' {A B C P : Type} {j1' : A -> P} {j2' : B -> P} {j3' : C -
   }.
 
 Arguments TriJoinRecData' {A B C P} j1' j2' j3'.
-Arguments Build_TriJoinRecData' {A B C P}%type_scope
-  (j1' j2' j3' j12' j13' j23' j123')%function_scope.
+Arguments Build_TriJoinRecData' {A B C P}%_type_scope
+  (j1' j2' j3' j12' j13' j23' j123')%_function_scope.
 
 Definition prism' {P : Type} {a b c : P}
   {ab : a = b} {ac : a = c} {bc : b = c} (abc : ab @ bc = ac)
diff --git a/theories/Homotopy/PinSn.v b/theories/Homotopy/PinSn.v
index 8c6774a6e29..26dd191c8d4 100644
--- a/theories/Homotopy/PinSn.v
+++ b/theories/Homotopy/PinSn.v
@@ -18,7 +18,6 @@ Local Open Scope pointed_scope.
 Section Pi1S1.
   Context `{Univalence}.
 
-  Local Open Scope int_scope.
   Local Open Scope pointed_scope.
 
   Theorem pi1_circle : Pi 1 [Circle, base] ≅ abgroup_Z.
diff --git a/theories/Homotopy/Smash.v b/theories/Homotopy/Smash.v
index 9d74ec97e23..cc26c8374cf 100644
--- a/theories/Homotopy/Smash.v
+++ b/theories/Homotopy/Smash.v
@@ -1,11 +1,13 @@
-Require Import Basics.
-Require Import Pointed.Core.
-Require Import Types.
+Require Import Basics.Overture Basics.PathGroupoids Basics.Tactics Basics.Equivalences.
+Require Import Types.Sum Types.Bool Types.Paths Types.Forall.
+Require Import WildCat.Core WildCat.Bifunctor WildCat.Equiv.
 Require Import Colimits.Pushout.
-Require Import Cubical.
+Require Import Cubical.DPath.
+Require Import Pointed.Core.
 
 Local Open Scope pointed_scope.
 Local Open Scope dpath_scope.
+Local Open Scope path_scope.
 
 (* Definition of smash product *)
 
@@ -15,8 +17,8 @@ Definition sum_to_prod (X Y : pType) : X + Y -> X * Y
 Definition sum_to_bool X Y : X + Y -> Bool
   := sum_ind _ (fun _ => false) (fun _ => true).
 
-Definition Smash (X Y : pType) : pType
-  := [Pushout (sum_to_prod X Y) (sum_to_bool X Y), pushl (point X, point Y)].
+Definition Smash@{u v w | u <= w, v <= w} (X : pType@{u}) (Y : pType@{v}) : pType@{w}
+  := [Pushout@{w w w w} (sum_to_prod@{w w w} X Y) (sum_to_bool@{u v w} X Y), pushl (point X, point Y)].
 
 Section Smash.
 
@@ -81,7 +83,7 @@ Section Smash.
     + intros [a b].
       apply Psm.
     + apply (Bool_ind _ Pr Pl).
-    + srapply sum_ind; intro; apply dp_path_transport^-1.
+    + srapply sum_ind.
       - apply Pgl.
       - apply Pgr.
   Defined.
@@ -90,124 +92,350 @@ Section Smash.
     {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
     (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
     (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a : X)
-    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a.
-  Proof.
-    apply dp_apD_path_transport.
-    refine (Pushout_ind_beta_pglue P _ _ _ (inl a) @ _).
-    unfold sum_ind.
-    by apply ap.
-  Qed.
+    : apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a
+    := Pushout_ind_beta_pglue P _ _ _ (inl a).
 
   Definition Smash_ind_beta_gluer {P : Smash X Y -> Type}
     {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
     (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
     (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (b : Y)
-    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b.
-  Proof.
-    apply dp_apD_path_transport.
-    refine (Pushout_ind_beta_pglue P _ _ _ (inr b) @ _).
-    unfold sum_ind.
-    by apply ap.
-  Qed.
+    : apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b
+    := Pushout_ind_beta_pglue P _ _ _ (inr b).
 
   Definition Smash_ind_beta_gluel' {P : Smash X Y -> Type}
     {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
     (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
     (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a b : X)
-    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel' a b)
+    : apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluel' a b)
     = (Pgl a) @Dp ((Pgl b)^D).
   Proof.
-    unfold gluel'.
-    rewrite dp_apD_pp, dp_apD_V.
-    by rewrite 2 Smash_ind_beta_gluel.
-  Qed.
+    lhs nrapply dp_apD_pp.
+    apply ap011.
+    1: apply Smash_ind_beta_gluel.
+    lhs nrapply dp_apD_V.
+    apply ap.
+    apply Smash_ind_beta_gluel.
+  Defined.
 
   Definition Smash_ind_beta_gluer' {P : Smash X Y -> Type}
     {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
     (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
     (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a b : Y)
-    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer' a b)
+    : apD (Smash_ind Psm Pl Pr Pgl Pgr) (gluer' a b)
     = (Pgr a) @Dp ((Pgr b)^D).
   Proof.
-    unfold gluer'.
-    rewrite dp_apD_pp, dp_apD_V.
-    by rewrite 2 Smash_ind_beta_gluer.
-  Qed.
+    lhs nrapply dp_apD_pp.
+    apply ap011.
+    1: apply Smash_ind_beta_gluer.
+    lhs nrapply dp_apD_V.
+    apply ap.
+    apply Smash_ind_beta_gluer.
+  Defined.
 
   Definition Smash_ind_beta_glue {P : Smash X Y -> Type}
     {Psm : forall a b, P (sm a b)} {Pl : P auxl} {Pr : P auxr}
     (Pgl : forall a, DPath P (gluel a) (Psm a pt) Pl)
     (Pgr : forall b, DPath P (gluer b) (Psm pt b) Pr) (a : X) (b : Y)
-    : dp_apD (Smash_ind Psm Pl Pr Pgl Pgr) (glue a b)
+    : apD (Smash_ind Psm Pl Pr Pgl Pgr) (glue a b)
     = ((Pgl a) @Dp ((Pgl pt)^D)) @Dp ((Pgr pt) @Dp ((Pgr b)^D)).
   Proof.
-    by rewrite dp_apD_pp, Smash_ind_beta_gluel', Smash_ind_beta_gluer'.
-  Qed.
+    lhs nrapply dp_apD_pp.
+    apply ap011.
+    - apply Smash_ind_beta_gluel'.
+    - apply Smash_ind_beta_gluer'.
+  Defined.
 
   Definition Smash_rec {P : Type} (Psm : X -> Y -> P) (Pl Pr : P)
     (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr)
-    : Smash X Y -> P := Smash_ind Psm Pl Pr
-      (fun x => dp_const (Pgl x)) (fun x => dp_const (Pgr x)).
-
-  Local Open Scope path_scope.
+    : Smash X Y -> P
+    := Smash_ind Psm Pl Pr (fun x => dp_const (Pgl x)) (fun x => dp_const (Pgr x)).
 
   (* Version of smash_rec that forces (Pgl pt) and (Pgr pt) to be idpath *)
   Definition Smash_rec' {P : Type} {Psm : X -> Y -> P}
     (Pgl : forall a, Psm a pt = Psm pt pt) (Pgr : forall b, Psm pt b = Psm pt pt)
     (ql : Pgl pt = 1) (qr : Pgr pt = 1)
-    : Smash X Y -> P := Smash_rec Psm (Psm pt pt) (Psm pt pt) Pgl Pgr.
+    : Smash X Y -> P
+    := Smash_rec Psm (Psm pt pt) (Psm pt pt) Pgl Pgr.
 
   Definition Smash_rec_beta_gluel {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
     (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a : X)
     : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluel a) = Pgl a.
   Proof.
-    refine (_ @ eissect dp_const (Pgl a)).
+    rhs_V nrapply (eissect dp_const).
     apply moveL_equiv_V.
-    unfold Smash_rec.
-    refine ((dp_apD_const (Smash_ind Psm Pl Pr (fun x : X => dp_const (Pgl x))
-      (fun x : Y => dp_const (Pgr x))) (gluel a))^ @ _).
-    rapply Smash_ind_beta_gluel.
-  Qed.
+    lhs_V nrapply dp_apD_const.
+    nrapply Smash_ind_beta_gluel.
+  Defined.
 
-  Definition smash_rec_beta_gluer {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
+  Definition Smash_rec_beta_gluer {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
     (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (b : Y)
     : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluer b) = Pgr b.
   Proof.
-    refine (_ @ eissect dp_const (Pgr b)).
+    rhs_V nrapply (eissect dp_const).
     apply moveL_equiv_V.
-    unfold Smash_rec.
-    refine ((dp_apD_const (Smash_ind Psm Pl Pr (fun x : X => dp_const (Pgl x))
-      (fun x : Y => dp_const (Pgr x))) (gluer b))^ @ _).
-    rapply Smash_ind_beta_gluer.
-  Qed.
+    lhs_V nrapply dp_apD_const.
+    nrapply Smash_ind_beta_gluer.
+  Defined.
 
   Definition Smash_rec_beta_gluel' {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
     (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a b : X)
     : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluel' a b) = Pgl a @ (Pgl b)^.
   Proof.
-    rewrite ap_pp, ap_V.
-    by rewrite 2 Smash_rec_beta_gluel.
-  Qed.
+    lhs nrapply ap_pp.
+    f_ap.
+    1: apply Smash_rec_beta_gluel.
+    lhs nrapply ap_V.
+    apply inverse2.
+    apply Smash_rec_beta_gluel.
+  Defined.
 
   Definition Smash_rec_beta_gluer' {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
     (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a b : Y)
     : ap (Smash_rec Psm Pl Pr Pgl Pgr) (gluer' a b) = Pgr a @ (Pgr b)^.
   Proof.
-    rewrite ap_pp, ap_V.
-    by rewrite 2 smash_rec_beta_gluer.
-  Qed.
+    lhs nrapply ap_pp.
+    f_ap.
+    1: apply Smash_rec_beta_gluer.
+    lhs nrapply ap_V.
+    apply inverse2.
+    apply Smash_rec_beta_gluer.
+  Defined.
 
-  Definition smash_rec_beta_glue {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
+  Definition Smash_rec_beta_glue {P : Type} {Psm : X -> Y -> P} {Pl Pr : P}
     (Pgl : forall a, Psm a pt = Pl) (Pgr : forall b, Psm pt b = Pr) (a : X)
     (b : Y) : ap (Smash_rec Psm Pl Pr Pgl Pgr) (glue a b)
     = ((Pgl a) @ (Pgl pt)^) @ (Pgr pt @ (Pgr b)^).
   Proof.
-    by rewrite ap_pp, Smash_rec_beta_gluel', Smash_rec_beta_gluer'.
+    lhs nrapply ap_pp.
+    f_ap.
+    - apply Smash_rec_beta_gluel'.
+    - apply Smash_rec_beta_gluer'.
   Defined.
 
-  Arguments sm : simpl never.
-  Arguments auxl : simpl never.
-  Arguments gluel : simpl never.
-  Arguments gluer : simpl never.
-
 End Smash.
+
+Arguments sm : simpl never.
+Arguments auxl : simpl never.
+Arguments gluel : simpl never.
+Arguments gluer : simpl never.
+
+(** ** Miscellaneous lemmas about Smash *)
+
+(** A version of [Smash_ind] specifically for proving that two functions from a [Smash] are homotopic. *)
+Definition Smash_ind_FlFr {A B : pType} {P : Type} (f g : Smash A B -> P)
+  (Hsm : forall a b, f (sm a b) = g (sm a b))
+  (Hl : f auxl = g auxl) (Hr : f auxr = g auxr)
+  (Hgluel : forall a, ap f (gluel a) @ Hl = Hsm a pt @ ap g (gluel a))
+  (Hgluer : forall b, ap f (gluer b) @ Hr = Hsm pt b @ ap g (gluer b))
+  : f == g.
+Proof.
+  snrapply (Smash_ind Hsm Hl Hr).
+  - intros a.
+    nrapply transport_paths_FlFr'.
+    exact (Hgluel a).
+  - intros b.
+    nrapply transport_paths_FlFr'.
+    exact (Hgluer b).
+Defined.
+
+(** A version of [Smash_ind]j specifically for proving that the composition of two functions is the identity map. *)
+Definition Smash_ind_FFlr {A B : pType} {P : Type}
+  (f : Smash A B -> P) (g : P -> Smash A B)
+  (Hsm : forall a b, g (f (sm a b)) = sm a b)
+  (Hl : g (f auxl) = auxl) (Hr : g (f auxr) = auxr)
+  (Hgluel : forall a, ap g (ap f (gluel a)) @ Hl = Hsm a pt @ gluel a)
+  (Hgluer : forall b, ap g (ap f (gluer b)) @ Hr = Hsm pt b @ gluer b)
+  : g o f == idmap.
+Proof.
+  snrapply (Smash_ind Hsm Hl Hr).
+  - intros a.
+    nrapply (transport_paths_FFlr' (f := f) (g := g)).
+    exact (Hgluel a).
+  - intros b.
+    nrapply (transport_paths_FFlr' (f := f) (g := g)).
+    exact (Hgluer b).
+Defined.
+
+(** ** Functoriality of the smash product *)
+
+Definition functor_smash {A B X Y : pType} (f : A $-> X) (g : B $-> Y)
+  : Smash A B $-> Smash X Y.
+Proof.
+  srapply Build_pMap.
+  - snrapply (Smash_rec (fun a b => sm (f a) (g b)) auxl auxr).
+    + intro a; cbn beta.
+      rhs_V nrapply (gluel (f a)).
+      exact (ap011 _ 1 (point_eq g)).
+    + intro b; cbn beta.
+      rhs_V nrapply (gluer (g b)).
+      exact (ap011 _ (point_eq f) 1).
+  - exact (ap011 _ (point_eq f) (point_eq g)).
+Defined.
+
+Definition functor_smash_idmap (X Y : pType)
+  : functor_smash (@pmap_idmap X) (@pmap_idmap Y) $== pmap_idmap.
+Proof.
+  snrapply Build_pHomotopy.
+  { snrapply Smash_ind_FlFr.
+    1-3: reflexivity.
+    - intros x.
+      apply equiv_p1_1q.
+      rhs nrapply ap_idmap.
+      lhs nrapply Smash_rec_beta_gluel.
+      apply concat_1p.
+    - intros y.
+      apply equiv_p1_1q.
+      rhs nrapply ap_idmap.
+      lhs nrapply Smash_rec_beta_gluer.
+      apply concat_1p. }
+  reflexivity.
+Defined.
+
+Definition functor_smash_compose {X Y A B C D : pType}
+  (f : X $-> A) (g : Y $-> B) (h : A $-> C) (k : B $-> D)
+  : functor_smash (h $o f) (k $o g) $== functor_smash h k $o functor_smash f g.
+Proof.
+  pointed_reduce.
+  snrapply Build_pHomotopy.
+  { snrapply Smash_ind_FlFr.
+    1-3: reflexivity.
+    - intros x.
+      apply equiv_p1_1q.
+      lhs nrapply Smash_rec_beta_gluel.
+      symmetry.
+      lhs nrapply (ap_compose (functor_smash _ _) _ (gluel x)).
+      lhs nrapply ap.
+      2: nrapply Smash_rec_beta_gluel.
+      lhs nrapply Smash_rec_beta_gluel.
+      apply concat_1p.
+    - intros y.
+      apply equiv_p1_1q.
+      lhs nrapply Smash_rec_beta_gluer.
+      symmetry.
+      lhs nrapply (ap_compose (functor_smash _ _) _ (gluer y)).
+      lhs nrapply ap.
+      2: nrapply Smash_rec_beta_gluer.
+      lhs nrapply Smash_rec_beta_gluer.
+      apply concat_1p. }
+  reflexivity.
+Defined.
+
+Definition functor_smash_homotopic {X Y A B : pType}
+  {f h : X $-> A} {g k : Y $-> B}
+  (p : f $== h) (q : g $== k)
+  : functor_smash f g $== functor_smash h k.
+Proof.
+  pointed_reduce.
+  snrapply Build_pHomotopy.
+  { snrapply Smash_ind_FlFr.
+    1: exact (fun x y => ap011 _ (p x) (q y)).
+    1,2: reflexivity.
+    - intros x.
+      lhs nrapply concat_p1.
+      lhs nrapply Smash_rec_beta_gluel.
+      rhs nrapply whiskerL.
+      2: nrapply Smash_rec_beta_gluel.
+      simpl; induction (p x); simpl.
+      rhs_V nrapply concat_pp_p.
+      apply whiskerR.
+      nrapply ap_pp.
+    - intros y.
+      lhs nrapply concat_p1.
+      lhs nrapply Smash_rec_beta_gluer.
+      rhs nrapply whiskerL.
+      2: nrapply Smash_rec_beta_gluer.
+      simpl; induction (q y); simpl.
+      rhs_V nrapply concat_pp_p.
+      apply whiskerR.
+      nrapply (ap011_pp _ _ _ 1 1). }
+  exact (ap022 _ (concat_p1 (p pt))^ (concat_p1 (q pt))^ @ (concat_p1 _)^).
+Defined.
+
+Global Instance is0bifunctor_smash : Is0Bifunctor Smash.
+Proof.
+  snrapply Build_Is0Bifunctor'.
+  1,2: exact _.
+  nrapply Build_Is0Functor.
+  intros [X Y] [A B] [f g].
+  exact (functor_smash f g).
+Defined.
+
+Global Instance is1bifunctor_smash : Is1Bifunctor Smash.
+Proof.
+  snrapply Build_Is1Bifunctor'.
+  snrapply Build_Is1Functor.
+  - intros [X Y] [A B] [f g] [h i] [p q].
+    exact (functor_smash_homotopic p q).
+  - intros [X Y].
+    exact (functor_smash_idmap X Y).
+  - intros [X Y] [A B] [C D] [f g] [h i].
+    exact (functor_smash_compose f g h i).
+Defined.
+
+(** ** Symmetry of the smash product *)
+
+Definition pswap (X Y : pType) : Smash X Y $-> Smash Y X
+  := Build_pMap _ _ (Smash_rec (flip sm) auxr auxl gluer gluel) 1.
+
+Definition pswap_pswap {X Y : pType}
+  : pswap X Y $o pswap Y X $== pmap_idmap.
+Proof.
+  snrapply Build_pHomotopy.
+  - snrapply Smash_ind_FFlr.
+    1-3: reflexivity.
+    + intros y.
+      apply equiv_p1_1q.
+      lhs nrapply ap.
+      1: apply Smash_rec_beta_gluel.
+      nrapply Smash_rec_beta_gluer.
+    + intros x.
+      apply equiv_p1_1q.
+      lhs nrapply ap.
+      1: apply Smash_rec_beta_gluer.
+      nrapply Smash_rec_beta_gluel.
+  - reflexivity.
+Defined.
+
+Definition pequiv_pswap {X Y : pType} : Smash X Y $<~> Smash Y X.
+Proof.
+  snrapply cate_adjointify.
+  1,2: exact (pswap _ _).
+  1,2: exact pswap_pswap.
+Defined.
+
+Definition pswap_natural {A B X Y : pType} (f : A $-> X) (g : B $-> Y)
+  : pswap X Y $o functor_smash f g $== functor_smash g f $o pswap A B.
+Proof.
+  pointed_reduce.
+  snrapply Build_pHomotopy.
+  - snrapply Smash_ind_FlFr.
+    1-3: reflexivity.
+    + intros a.
+      apply equiv_p1_1q.
+      rhs nrapply (ap_compose (pswap _ _) _ (gluel a)).
+      rhs nrapply ap.
+      2: apply Smash_rec_beta_gluel.
+      rhs nrapply Smash_rec_beta_gluer.
+      lhs nrapply (ap_compose (functor_smash _ _) (pswap _ _) (gluel a)).
+      lhs nrapply ap.
+      1: apply Smash_rec_beta_gluel.
+      simpl.
+      lhs nrapply ap.
+      1: apply concat_1p.
+      rhs nrapply concat_1p.
+      nrapply Smash_rec_beta_gluel.
+    + intros b.
+      apply equiv_p1_1q.
+      rhs nrapply (ap_compose (pswap _ _) (functor_smash _ _) (gluer b)).
+      rhs nrapply ap.
+      2: apply Smash_rec_beta_gluer.
+      rhs nrapply Smash_rec_beta_gluel.
+      lhs nrapply (ap_compose (functor_smash _ _) (pswap _ _) (gluer b)).
+      lhs nrapply ap.
+      1: apply Smash_rec_beta_gluer.
+      lhs nrapply ap.
+      1: apply concat_1p.
+      rhs nrapply concat_1p.
+      nrapply Smash_rec_beta_gluer.
+  - reflexivity.
+Defined.
diff --git a/theories/Homotopy/SuccessorStructure.v b/theories/Homotopy/SuccessorStructure.v
index 49b8752b866..66e8997b752 100644
--- a/theories/Homotopy/SuccessorStructure.v
+++ b/theories/Homotopy/SuccessorStructure.v
@@ -1,6 +1,6 @@
 Require Import Basics.
 Require Import Nat.Core.
-Require Import Spaces.Int.Core.
+Require Import Spaces.Int.
 Require Import Spaces.Finite.Fin.
 Require Import WildCat.Core.
 
@@ -27,13 +27,13 @@ Arguments ss_succ {_} _.
 Notation "x .+1" := (ss_succ x) : succ_scope.
 
 (** Successor structure of naturals *)
-Definition NatSucc : SuccStr := Build_SuccStr nat Nat.Core.succ.
+Definition NatSucc : SuccStr := Build_SuccStr nat nat_succ.
 
 (** Successor structure of integers *)
-Definition IntSucc : SuccStr := Build_SuccStr Int int_succ.
+Definition BinIntSucc : SuccStr := Build_SuccStr Int int_succ.
 
 Notation "'+N'" := NatSucc : succ_scope.
-Notation "'+Z'" := IntSucc : succ_scope.
+Notation "'+Z'" := BinIntSucc : succ_scope.
 
 (** Stratified successor structures *)
 
@@ -217,7 +217,8 @@ Defined.
 
 Global Instance is1cat_ss : Is1Cat SuccStr.
 Proof.
-  srapply Build_Is1Cat.
+  snrapply Build_Is1Cat'.
+  1,2: exact _.
   - intros X Y Z g.
     snrapply Build_Is0Functor.
     intros f h p.
diff --git a/theories/Homotopy/Suspension.v b/theories/Homotopy/Suspension.v
index 18408779fc6..b3173ed52c2 100644
--- a/theories/Homotopy/Suspension.v
+++ b/theories/Homotopy/Suspension.v
@@ -37,20 +37,6 @@ Proof.
   - exact (H_merid).
 Defined.
 
-(** Here is an alternative induction principle using DPath's instead of transports *)
-Definition Susp_ind_dp {X : Type} (P : Susp X -> Type)
-  (H_N : P North) (H_S : P South)
-  (H_merid : forall x:X, DPath P (merid x) H_N H_S)
-  : forall (y : Susp X), P y.
-Proof.
-  srapply Susp_ind.
-  - exact H_N.
-  - exact H_S.
-  - intro x.
-    apply dp_path_transport^-1.
-    exact (H_merid x).
-Defined.
-
 (** We can also derive the computation rule *)
 Definition Susp_ind_beta_merid {X : Type}
   (P : Susp X -> Type) (H_N : P North) (H_S : P South)
@@ -60,16 +46,6 @@ Proof.
   srapply Pushout_ind_beta_pglue.
 Defined.
 
-(** And similarly for the DPath version *)
-Definition Susp_ind_dp_beta_merid {X : Type}
-  (P : Susp X -> Type) (H_N : P North) (H_S : P South)
-  (H_merid : forall x:X, DPath P (merid x) H_N H_S) (x : X)
-  : dp_apD (Susp_ind_dp P H_N H_S H_merid) (merid x) = H_merid x.
-Proof.
-  apply dp_apD_path_transport.
-  srapply Susp_ind_beta_merid.
-Defined.
-
 (** We want to allow the user to forget that we've defined suspension as a pushout and make it look like it was defined directly as a HIT. This has the advantage of not having to assume any new HITs but allowing us to have conceptual clarity. *)
 Arguments Susp : simpl never.
 Arguments North : simpl never.
@@ -99,7 +75,7 @@ Definition Susp_rec {X Y : Type}
   : Susp X -> Y
   := Pushout_rec (f:=const_tt X) (g:=const_tt X) Y (Unit_ind H_N) (Unit_ind H_S) H_merid.
 
-Global Arguments Susp_rec {X Y}%type_scope H_N H_S H_merid%function_scope _.
+Global Arguments Susp_rec {X Y}%_type_scope H_N H_S H_merid%_function_scope _.
 
 Definition Susp_rec_beta_merid {X Y : Type}
   {H_N H_S : Y} {H_merid : X -> H_N = H_S} (x:X)
@@ -124,22 +100,6 @@ Proof.
   apply ap, inverse. refine (Susp_ind_beta_merid _ _ _ _ _).
 Defined.
 
-Definition Susp_eta_homot_dp {X : Type} {P : Susp X -> Type} (f : forall y, P y)
-  : f == Susp_ind_dp P (f North) (f South) (fun x => dp_apD f (merid x)).
-Proof.
-  unfold pointwise_paths. refine (Susp_ind_dp _ 1 1 _).
-  intros x.
-  apply dp_paths_FlFr_D.
-  cbn.
-  refine (concat_pp_p _ _ _ @ _).
-  apply moveR_Vp.
-  apply equiv_1p_q1.
-  apply (equiv_inj dp_path_transport).
-  refine (dp_path_transport_apD _ _ @ _). 
-  refine (_ @ (dp_path_transport_apD f (merid x))^).
-  srapply Susp_ind_dp_beta_merid.
-Defined.
-
 Definition Susp_rec_eta_homot {X Y : Type} (f : Susp X -> Y)
   : f == Susp_rec (f North) (f South) (fun x => ap f (merid x)).
 Proof.
@@ -245,44 +205,28 @@ Section UnivProp.
   (** Here is the domain of the equivalence: sections of [P] over [Susp X]. *)
   Definition Susp_ind_type := forall z:Susp X, P z.
 
+  (** [isgraph_paths] is not a global instance, so we define this by hand.  The fact that this is a 01cat and a 0gpd is obtained using global instances. *)
   Local Instance isgraph_Susp_ind_type : IsGraph Susp_ind_type.
   Proof. apply isgraph_forall; intros; apply isgraph_paths. Defined.
 
-  Local Instance is01cat_Susp_ind_type : Is01Cat Susp_ind_type.
-  Proof. apply is01cat_forall; intros; apply is01cat_paths. Defined.
-
-  Local Instance is0gpd_Susp_ind_type : Is0Gpd Susp_ind_type.
-  Proof. apply is0gpd_forall; intros; apply is0gpd_paths. Defined.
-
   (** The codomain is a sigma-groupoid of this family, consisting of input data for [Susp_ind]. *)
   Definition Susp_ind_data' (NS : P North * P South)
     := forall x:X, DPath P (merid x) (fst NS) (snd NS).
 
+  (** Again, the rest of the wild category structure is obtained using global instances. *)
   Local Instance isgraph_Susp_ind_data' NS : IsGraph (Susp_ind_data' NS).
   Proof. apply isgraph_forall; intros; apply isgraph_paths. Defined.
 
-  Local Instance is01cat_Susp_ind_data' NS : Is01Cat (Susp_ind_data' NS).
-  Proof. apply is01cat_forall; intros; apply is01cat_paths. Defined.
-
-  Local Instance is0gpd_Susp_ind_data' NS : Is0Gpd (Susp_ind_data' NS).
-  Proof. apply is0gpd_forall; intros; apply is0gpd_paths. Defined.
-
-  (** Here is the codomain itself. *)
+  (** Here is the codomain itself.  This is a 01cat and a 0gpd via global instances. *)
   Definition Susp_ind_data := sig Susp_ind_data'.
 
-  Local Instance is01cat_Susp_ind_data : Is01Cat Susp_ind_data.
-  Proof. rapply is01cat_sigma. Defined.
-
-  Local Instance is0gpd_Susp_ind_data : Is0Gpd Susp_ind_data.
-  Proof. rapply is0gpd_sigma. Defined.
-
   (** Here is the functor. *)
   Definition Susp_ind_inv : Susp_ind_type -> Susp_ind_data.
   Proof.
     intros f.
     exists (f North,f South).
     intros x.
-    exact (dp_apD f (merid x)).
+    exact (apD f (merid x)).
   Defined.
 
   Local Instance is0functor_susp_ind_inv : Is0Functor Susp_ind_inv.
@@ -302,12 +246,12 @@ Section UnivProp.
   Proof.
     constructor.
     - intros [[n s] g].
-      exists (Susp_ind_dp P n s g); cbn.
+      exists (Susp_ind P n s g); cbn.
       exists idpath.
       intros x; cbn.
-      apply Susp_ind_dp_beta_merid.
+      apply Susp_ind_beta_merid.
     - intros f g [p q]; cbn in *.
-      srapply Susp_ind_dp; cbn.
+      srapply Susp_ind; cbn.
       1: exact (ap fst p).
       1: exact (ap snd p).
       intros x; specialize (q x).
@@ -327,22 +271,17 @@ Section UnivPropNat.
   (** We will show that [Susp_ind_inv] for [X] and [Y] commute with precomposition with [f] and [functor_susp f]. *)
   Context {X Y : Type} (f : X -> Y) (P : Susp Y -> Type).
 
-  (** We recall all those instances from the previous section. *)
-  Local Existing Instances isgraph_Susp_ind_type is01cat_Susp_ind_type is0gpd_Susp_ind_type isgraph_Susp_ind_data' is01cat_Susp_ind_data' is0gpd_Susp_ind_data' is01cat_Susp_ind_data is0gpd_Susp_ind_data.
+  (** We recall these instances from the previous section. *)
+  Local Existing Instances isgraph_Susp_ind_type isgraph_Susp_ind_data'.
 
   (** Here is an intermediate family of groupoids that we have to use, since precomposition with [f] doesn't land in quite the right place. *)
   Definition Susp_ind_data'' (NS : P North * P South)
     := forall x:X, DPath P (merid (f x)) (fst NS) (snd NS).
 
+  (** This is a 01cat and a 0gpd via global instances. *)
   Local Instance isgraph_Susp_ind_data'' NS : IsGraph (Susp_ind_data'' NS).
   Proof. apply isgraph_forall; intros; apply isgraph_paths. Defined.
 
-  Local Instance is01cat_Susp_ind_data'' NS : Is01Cat (Susp_ind_data'' NS).
-  Proof. apply is01cat_forall; intros; apply is01cat_paths. Defined.
-
-  Local Instance is0gpd_Susp_ind_data'' NS : Is0Gpd (Susp_ind_data'' NS).
-  Proof. apply is0gpd_forall; intros; apply is0gpd_paths. Defined.
-
   (** We decompose "precomposition with [f]" into a functor_sigma of two fiberwise functors.  Here is the first. *)
   Definition functor_Susp_ind_data'' (NS : P North * P South)
     : Susp_ind_data' Y P NS -> Susp_ind_data'' NS
@@ -433,12 +372,12 @@ Section UnivPropNat.
       $=> functor_Susp_ind_data o (Susp_ind_inv Y P).
   Proof.
     intros g; exists idpath; intros x.
-    change (dp_apD (fun x0 : Susp X => g (functor_susp f x0)) (merid x) =
+    change (apD (fun x0 : Susp X => g (functor_susp f x0)) (merid x) =
             (functor_Susp_ind_data (Susp_ind_inv Y P g)).2 x).
     refine (dp_apD_compose (functor_susp f) P (merid x) g @ _).
     cbn; apply ap.
     apply (moveL_transport_V (fun p => DPath P p (g North) (g South))).
-    exact (apD (dp_apD g) (functor_susp_beta_merid f x)).
+    exact (apD (apD g) (functor_susp_beta_merid f x)).
   Defined.
 
   (** From this we can deduce a equivalence between extendability, which is definitionally equal to split essential surjectivity of a functor between forall 0-groupoids. *)
@@ -478,21 +417,21 @@ Proof.
     + apply extension_iff_functor_susp.
       exact e1.
     + cbn; intros h k.
-      pose (h' := Susp_ind_dp P N S h).
-      pose (k' := Susp_ind_dp P N S k).
+      pose (h' := Susp_ind P N S h).
+      pose (k' := Susp_ind P N S k).
       specialize (en h' k').
       assert (IH := fst (IHn _) en (1,1)); clear IHn en.
       cbn in IH.
       refine (extendable_postcompose' n _ _ f _ IH); clear IH.
       intros y.
       etransitivity.
-      1: apply ds_dp.
+      1: nrapply ds_dp.
       etransitivity.
       1: apply ds_transport_dpath.
       subst h' k'; cbn.
       apply equiv_concat_lr.
-      * symmetry. exact (Susp_ind_dp_beta_merid P N S h y).
-      * exact (Susp_ind_dp_beta_merid P N S k y).
+      * symmetry. exact (Susp_ind_beta_merid P N S h y).
+      * exact (Susp_ind_beta_merid P N S k y).
   - intros e; split.
     + apply extension_iff_functor_susp.
       intros NS; exact (fst (e NS)).
@@ -504,7 +443,7 @@ Proof.
       refine (extendable_postcompose' n _ _ f _ (e _ _)); intros y.
       symmetry.
       etransitivity.
-      1: apply ds_dp.
+      1: nrapply ds_dp.
       etransitivity.
       1: apply ds_transport_dpath.
       etransitivity.
diff --git a/theories/Homotopy/Wedge.v b/theories/Homotopy/Wedge.v
index 75246ed14dc..69e1b10c1bb 100644
--- a/theories/Homotopy/Wedge.v
+++ b/theories/Homotopy/Wedge.v
@@ -70,17 +70,16 @@ Definition wedge_incl (X Y : pType) : X \/ Y $-> X * Y
 Definition wedge_incl_beta_wglue {X Y : pType}
   : ap (@wedge_incl X Y) wglue = 1.
 Proof.
-  lhs nrapply (eta_path_prod _)^.
+  lhs_V nrapply eta_path_prod.
   lhs nrapply ap011.
-  - lhs nrapply (ap_compose _ _ _)^.
+  - lhs_V nrapply ap_compose.
     nrapply wedge_rec_beta_wglue.
-  - lhs nrapply (ap_compose _ _ _)^.
+  - lhs_V nrapply ap_compose.
     nrapply wedge_rec_beta_wglue.
   - reflexivity.
 Defined.
 
 (** 1-universal property of wedge. *)
-(** TODO: remove rewrites. For some reason pelim is not able to immediately abstract the goal so some shuffling around is necessary. *)
 Lemma wedge_up X Y Z (f g : X \/ Y $-> Z)
   : f $o wedge_inl $== g $o wedge_inl
   -> f $o wedge_inr $== g $o wedge_inr
@@ -90,20 +89,34 @@ Proof.
   snrapply Build_pHomotopy.
   - snrapply (Pushout_ind _ p q).
     intros [].
-    simpl.
-    refine (transport_paths_FlFr _ _ @ _).
-    refine (concat_pp_p _ _ _ @ _).
-    apply moveR_Vp.
-    refine (whiskerR (dpoint_eq p) _ @ _).
-    refine (_ @ whiskerL _ (dpoint_eq q)^).
+    nrapply transport_paths_FlFr'.
+    lhs nrapply (whiskerL _ (dpoint_eq q)).
+    rhs nrapply (whiskerR (dpoint_eq p)).
     clear p q.
+    lhs nrapply concat_p_pp.
     simpl.
-    apply moveL_Mp.
-    rewrite ? ap_V.
-    rewrite ? inv_pp.
-    hott_simpl.
+    apply moveR_pV.
+    lhs nrapply whiskerL.
+    { nrapply whiskerR.
+      apply ap_V. }
+    lhs nrapply concat_p_pp.
+    lhs nrapply whiskerR.
+    1: apply concat_pV.
+    rhs nrapply concat_p_pp.
+    apply moveL_pM.
+    lhs_V nrapply concat_p1.
+    lhs nrapply concat_pp_p.
+    lhs_V nrapply whiskerL.
+    1: apply (inv_pp 1).
+    rhs nrapply whiskerL.
+    2: apply ap_V.
+    apply moveL_pV.
+    reflexivity.
   - simpl; pelim p q.
-    hott_simpl.
+    f_ap.
+    1: apply concat_1p.
+    lhs nrapply inv_pp.
+    apply concat_p1.
 Defined.
 
 Global Instance hasbinarycoproducts : HasBinaryCoproducts pType.
@@ -181,14 +194,14 @@ Proof.
     exact pt.
 Defined.
 
+Definition fwedge_in' (I : Type) (X : I -> pType)
+  : forall i, X i $-> FamilyWedge I X
+  := fun i => Build_pMap _ _ (fun x => pushl (i; x)) (pglue i).
+
 (** We have an inclusion map [pushl : sig X -> FamilyWedge X].  When [I] is pointed, so is [sig X], and then this inclusion map is pointed. *)
 Definition fwedge_in (I : pType) (X : I -> pType)
-  : psigma (pointed_fam X) $-> FamilyWedge I X.
-Proof.
-  snrapply Build_pMap.
-  - exact pushl.
-  - exact (pglue pt).
-Defined.
+  : psigma (pointed_fam X) $-> FamilyWedge I X
+  := Build_pMap _ _ pushl (pglue pt).
 
 (** Recursion principle for the wedge of an indexed family of pointed types. *)
 Definition fwedge_rec (I : Type) (X : I -> pType) (Z : pType)
@@ -204,19 +217,45 @@ Proof.
   - exact idpath.
 Defined.
 
-(** Wedge inclusions into the product can be defined if the indexing type has decidable paths. This is because we need to choose which factor a given wedge should land. This makes it somewhat awkward to work with, however in practice we typically only care about decidable index sets. *)
-Definition fwedge_incl `{Funext} (I : Type) `(DecidablePaths I) (X : I -> pType)
-  : FamilyWedge I X $-> pproduct X.
+(** We specify a universe variable here to prevent minimization to [Set]. *)
+Global Instance hasallcoproducts_ptype : HasAllCoproducts pType@{u}.
 Proof.
-  snrapply fwedge_rec.
-  intro i.
-  snrapply pproduct_corec.
-  intro a.
-  destruct (dec_paths i a).
-  - destruct p; exact pmap_idmap.
-  - exact pconst.
+  intros I X.
+  snrapply Build_Coproduct.
+  - exact (FamilyWedge I X).
+  - exact (fwedge_in' I X).
+  - exact (fwedge_rec I X).
+  - intros Z f i.
+    snrapply Build_pHomotopy.
+    1: reflexivity.
+    simpl.
+    apply moveL_pV.
+    apply equiv_1p_q1.
+    symmetry.
+    exact (Pushout_rec_beta_pglue Z _ (unit_name pt) (fun i => point_eq (f i)) _).
+  - intros Z f g h.
+    snrapply Build_pHomotopy.
+    + snrapply Pushout_ind.
+      * intros [i x].
+        nrapply h.
+      * intros [].
+        exact (point_eq _ @ (point_eq _)^).
+      * intros i; cbn.
+        nrapply transport_paths_FlFr'.
+        lhs nrapply concat_p_pp.
+        apply moveR_pV.
+        rhs nrapply concat_pp_p.
+        apply moveL_pM.
+        symmetry.
+        exact (dpoint_eq (h i)).
+    + reflexivity.
 Defined.
 
+(** Wedge inclusions into the product can be defined if the indexing type has decidable paths. This is because we need to choose which factor a given wedge summand should land in. *)
+Definition fwedge_incl `{Funext} (I : Type) `(DecidablePaths I) (X : I -> pType)
+  : FamilyWedge I X $-> pproduct X
+  := cat_coprod_prod X.
+
 (** ** The pinch map on the suspension *)
 
 (** Given a suspension, there is a natural map from the suspension to the wedge of the suspension with itself. This is known as the pinch map.
diff --git a/theories/Limits/Pullback.v b/theories/Limits/Pullback.v
index 86f1d4cbcea..d0e90b25233 100644
--- a/theories/Limits/Pullback.v
+++ b/theories/Limits/Pullback.v
@@ -11,7 +11,7 @@ Local Open Scope path_scope.
 Definition Pullback {A B C} (f : B -> A) (g : C -> A)
   := { b : B & { c : C & f b = g c }}.
 
-Global Arguments Pullback {A B C}%type_scope (f g)%function_scope.
+Global Arguments Pullback {A B C}%_type_scope (f g)%_function_scope.
 
 (** The universal commutative square *)
 Definition pullback_pr1 {A B C} {f : B -> A} {g : C -> A}
@@ -29,6 +29,37 @@ Definition pullback_corec {A B C D}
 : A -> Pullback k g
 := fun a => (f a ; h a ; p a).
 
+Definition pullback_corec_uncurried {A B C D} (k : B -> D) (g : C -> D)
+  : { f : A -> B & { h : A -> C & k o f == g o h }} -> (A -> Pullback k g).
+Proof.
+  intros [f [h p]].
+  exact (pullback_corec p).
+Defined.
+
+Global Instance isequiv_pullback_corec {A B C D} (k : B -> D) (g : C -> D)
+  : IsEquiv (@pullback_corec_uncurried A B C D k g).
+Proof.
+  snrapply isequiv_adjointify.
+  - intro m.
+    exact (pullback_pr1 o m ; pullback_pr2 o m ; (pullback_commsq k g) o m).
+  - reflexivity.
+  - reflexivity.
+Defined.
+
+Definition equiv_pullback_corec {A B C D} (k : B -> D) (g : C -> D)
+  : { f : A -> B & { h : A -> C & k o f == g o h }} <~> (A -> Pullback k g)
+  := Build_Equiv _ _ _ (isequiv_pullback_corec k g).
+
+(** A homotopy commutative square is equivalent to a pullback of arrow types *)
+Definition equiv_ispullback_commsq `{Funext} {A B C D} (k : B -> D) (g : C -> D)
+  : { f : A -> B & { h : A -> C & k o f == g o h }}
+    <~> @Pullback (A -> D) (A -> B) (A -> C) (fun f => k o f) (fun h => g o h).
+Proof.
+  apply equiv_functor_sigma_id; intro f.
+  apply equiv_functor_sigma_id; intro h.
+  apply equiv_path_forall.
+Defined.
+
 (** The diagonal of a map *)
 Definition diagonal {X Y : Type} (f : X -> Y) : X -> Pullback f f
   := fun x => (x;x;idpath).
diff --git a/theories/Modalities/Descent.v b/theories/Modalities/Descent.v
index a6c6bdba951..2bb68d9cff3 100644
--- a/theories/Modalities/Descent.v
+++ b/theories/Modalities/Descent.v
@@ -1,7 +1,7 @@
 (* -*- mode: coq; mode: visual-line -*-  *)
 Require Import HoTT.Basics HoTT.Types.
 Require Import HFiber Extensions Limits.Pullback.
-Require Import Modality Accessible Localization.
+Require Import Modality Accessible Modalities.Localization.
 
 Local Open Scope path_scope.
 Local Open Scope subuniverse_scope.
diff --git a/theories/Modalities/Fracture.v b/theories/Modalities/Fracture.v
index 72a7a0651d1..c9e306bee33 100644
--- a/theories/Modalities/Fracture.v
+++ b/theories/Modalities/Fracture.v
@@ -107,7 +107,7 @@ It may sometimes happen that in addition, the "intersection" of [O1] and [O2] is
                      (O_functor O2 (to O1 (Pullback f (to O2 B)))
                                 ((O_rec (f^* (to O2 B)))^-1 c)));
         [ apply ap11; repeat apply ap
-        | transitivity (O_functor O2 (O_rec (to O2 B^*' f))
+        | transitivity (O_functor O2 (O_rec ((to O2 B)^*' f))
                           (O_functor O2 (to O1 (Pullback f (to O2 B)))
                                      ((O_rec (f^* (to O2 B)))^-1 c))) ].
       + refine (pr1_path_sigma_uncurried _ @ eisretr pr1 _).
diff --git a/theories/Modalities/Lex.v b/theories/Modalities/Lex.v
index 7ffc61cabe4..68c0c725d55 100644
--- a/theories/Modalities/Lex.v
+++ b/theories/Modalities/Lex.v
@@ -1,7 +1,7 @@
 (* -*- mode: coq; mode: visual-line -*- *)
 Require Import HoTT.Basics HoTT.Types.
 Require Import HFiber Limits.Pullback Factorization Truncations.Core.
-Require Import Modality Accessible Localization Descent Separated.
+Require Import Modality Accessible Modalities.Localization Descent Separated.
 
 Local Open Scope path_scope.
 Local Open Scope subuniverse_scope.
diff --git a/theories/Modalities/Nullification.v b/theories/Modalities/Nullification.v
index cc037219ceb..ac6dda799fc 100644
--- a/theories/Modalities/Nullification.v
+++ b/theories/Modalities/Nullification.v
@@ -4,7 +4,7 @@
 Require Import HoTT.Basics HoTT.Types.
 Require Import Extensions.
 Require Import Modality Accessible.
-Require Export Localization.    (** Nullification is a special case of localization *)
+Require Export Modalities.Localization.    (** Nullification is a special case of localization *)
 
 Local Open Scope path_scope.
 
diff --git a/theories/Modalities/ReflectiveSubuniverse.v b/theories/Modalities/ReflectiveSubuniverse.v
index 5c6bd70469f..72480c5ea88 100644
--- a/theories/Modalities/ReflectiveSubuniverse.v
+++ b/theories/Modalities/ReflectiveSubuniverse.v
@@ -241,12 +241,12 @@ Section ORecursion.
 End ORecursion.
 
 (* We never want to see [extendable_to_O].  The [!x] allows [cbn] to unfold these when passed a constructor, such as [tr x].  This, for example, means that [O_rec (O:=Tr n) f (tr x)] will compute to [f x] and [Trunc_functor n f (tr x)] will compute to [tr (f x)]. *)
-Arguments O_rec {O} {P Q}%type_scope {Q_inO H H0} f%function_scope !x.
-Arguments O_rec_beta {O} {P Q}%type_scope {Q_inO H H0} f%function_scope !x.
-Arguments O_indpaths {O} {P Q}%type_scope {Q_inO H H0} (g h)%function_scope p !x.
-Arguments O_indpaths_beta {O} {P Q}%type_scope {Q_inO H H0} (g h)%function_scope p !x.
-Arguments O_ind2paths {O} {P Q}%type_scope {Q_inO H H0} {g h}%function_scope p q r !x.
-Arguments O_ind2paths_beta {O} {P Q}%type_scope {Q_inO H H0} {g h}%function_scope p q r !x.
+Arguments O_rec {O} {P Q}%_type_scope {Q_inO H H0} f%_function_scope !x.
+Arguments O_rec_beta {O} {P Q}%_type_scope {Q_inO H H0} f%_function_scope !x.
+Arguments O_indpaths {O} {P Q}%_type_scope {Q_inO H H0} (g h)%_function_scope p !x.
+Arguments O_indpaths_beta {O} {P Q}%_type_scope {Q_inO H H0} (g h)%_function_scope p !x.
+Arguments O_ind2paths {O} {P Q}%_type_scope {Q_inO H H0} {g h}%_function_scope p q r !x.
+Arguments O_ind2paths_beta {O} {P Q}%_type_scope {Q_inO H H0} {g h}%_function_scope p q r !x.
 
 (** A tactic that generalizes [strip_truncations] to reflective subuniverses. [strip_truncations] introduces fewer universe variables, so tends to work better when removing truncations. [strip_modalities] in Modality.v also applies dependent elimination when [O] is a modality. *)
 Ltac strip_reflections :=
diff --git a/theories/NullHomotopy.v b/theories/NullHomotopy.v
index ee0b1831ec9..f6e9a4ecace 100644
--- a/theories/NullHomotopy.v
+++ b/theories/NullHomotopy.v
@@ -1,6 +1,6 @@
 (* -*- mode: coq; mode: visual-line -*- *)
 Require Import HoTT.Basics.
-Require Import Types.Sigma Types.Forall.
+Require Import Types.Sigma.
 Local Open Scope path_scope.
 
 
diff --git a/theories/ObjectClassifier.v b/theories/ObjectClassifier.v
index be310f1ec4a..44b50dd1657 100644
--- a/theories/ObjectClassifier.v
+++ b/theories/ObjectClassifier.v
@@ -87,7 +87,7 @@ Proof.
   - refine (_ oE _).
     + do 5 (rapply equiv_functor_sigma_id; intro).
       apply equiv_path_sigma.
-    + make_equiv_contr_basedpaths.
+    + cbn; make_equiv_contr_basedpaths.
   - refine (_ oE _).
     2: { do 5 (rapply equiv_functor_sigma_id; intro).
          exact (equiv_path_inverse _ _ oE equiv_moveL_equiv_M _ _). }
diff --git a/theories/Pointed/Core.v b/theories/Pointed/Core.v
index ccc4d84ac5c..ec69938b3b9 100644
--- a/theories/Pointed/Core.v
+++ b/theories/Pointed/Core.v
@@ -165,6 +165,15 @@ Proof.
     apply point_eq.
 Defined.
 
+Definition pproduct_proj {A : Type} {F : A -> pType} (a : A)
+  : pproduct F ->* F a.
+Proof.
+  snrapply Build_pMap.
+  - intros x.
+    exact (x a).
+  - reflexivity.
+Defined.
+
 (** The projections from a pointed product are pointed maps. *)
 Definition pfst {A B : pType} : A * B ->* A
   := Build_pMap (A * B) A fst idpath.
@@ -561,7 +570,8 @@ Defined.
 (** pType is a 1-coherent 1-category *)
 Global Instance is1cat_ptype : Is1Cat pType.
 Proof.
-  econstructor.
+  snrapply Build_Is1Cat'.
+  1, 2: exact _.
   - intros A B C h; rapply Build_Is0Functor.
     intros f g p; cbn.
     apply pmap_postwhisker; assumption.
@@ -593,7 +603,8 @@ Definition path_zero_morphism_pconst (A B : pType)
 (** pForall is a 1-category *)
 Global Instance is1cat_pforall (A : pType) (P : pFam A) : Is1Cat (pForall A P) | 10.
 Proof.
-  econstructor.
+  snrapply Build_Is1Cat'.
+  1, 2: exact _.
   - intros f g h p; rapply Build_Is0Functor.
     intros q r s. exact (phomotopy_postwhisker s p).
   - intros f g h p; rapply Build_Is0Functor.
@@ -644,23 +655,38 @@ Proof.
       srapply Build_pHomotopy.
       1: reflexivity.
       by pelim f p q i g h.
-  - intros A B C D f g r1 r2 s1.
+  - intros A B C f g h k p q.
+    snrapply Build_pHomotopy.
+    + intros x.
+      exact (concat_Ap q _)^.
+    + by pelim p f g q h k.
+  - intros A B C D f g.
+    snrapply Build_Is1Natural.
+    intros r1 r2 s1.
     srapply Build_pHomotopy.
     1: exact (fun _ => concat_p1 _ @ (concat_1p _)^).
     by pelim f g s1 r1 r2.
-  - intros A B C D f g r1 r2 s1.
+  - intros A B C D f g.
+    snrapply Build_Is1Natural.
+    intros r1 r2 s1.
     srapply Build_pHomotopy.
     1: exact (fun _ => concat_p1 _ @ (concat_1p _)^).
     by pelim f s1 r1 r2 g.
-  - intros A B C D f g r1 r2 s1.
+  - intros A B C D f g.
+    snrapply Build_Is1Natural.
+    intros r1 r2 s1.
     srapply Build_pHomotopy.
     1: cbn; exact (fun _ => concat_p1 _ @ ap_compose _ _ _ @ (concat_1p _)^).
     by pelim s1 r1 r2 f g.
-  - intros A B r1 r2 s1.
+  - intros A B.
+    snrapply Build_Is1Natural.
+    intros r1 r2 s1.
     srapply Build_pHomotopy.
     1: exact (fun _ => concat_p1 _ @ ap_idmap _ @ (concat_1p _)^).
     by pelim s1 r1 r2.
-  - intros A B r1 r2 s1.
+  - intros A B.
+    snrapply Build_Is1Natural.
+    intros r1 r2 s1.
     srapply Build_pHomotopy.
     1: exact (fun _ => concat_p1 _ @ (concat_1p _)^).
     simpl; by pelim s1 r1 r2.
@@ -711,6 +737,34 @@ Proof.
     by pelim p q f g.
 Defined.
 
+(** pType has I-indexed product. *)
+Global Instance hasallproducts_ptype `{Funext} : HasAllProducts pType.
+Proof.
+  intros I x.
+  snrapply Build_Product.
+  - exact (pproduct x).
+  - exact pproduct_proj. 
+  - exact (pproduct_corec x).
+  - intros Z f i.
+    snrapply Build_pHomotopy.
+    1: reflexivity.
+    apply moveL_pV.
+    apply equiv_1p_q1.
+    exact (apD10_path_forall _ _ (fun a => point_eq (f a)) i)^.
+  - intros Z f g p.
+    snrapply Build_pHomotopy.
+    1: intros z; funext i; apply p.
+    cbn; apply moveR_equiv_V.
+    funext i.
+    rhs nrapply ap_pp.
+    lhs nrapply (dpoint_eq (p i)).
+    cbn; f_ap.
+    + apply concat_p1.
+    + rhs nrapply (ap_V _ (dpoint_eq g)).
+      apply inverse2.
+      apply concat_p1.
+Defined.
+
 (** Some higher homotopies *)
 
 (** Horizontal composition of homotopies. *)
@@ -876,12 +930,12 @@ Proof.
 Defined.
 
 (** Univalence for pointed types *)
-Definition equiv_path_ptype `{Univalence} (A B : pType) : A <~>* B <~> A = B.
+Definition equiv_path_ptype `{Univalence} (A B : pType@{u}) : A <~>* B <~> A = B.
 Proof.
   refine (equiv_path_from_contr A (fun C => A <~>* C) pequiv_pmap_idmap _ B).
-  nrapply (contr_equiv' { X : Type & { f : A <~> X & {x : X & f pt = x} }}).
+  nrapply (contr_equiv' { X : Type@{u} & { f : A <~> X & {x : X & f pt = x} }}).
   1: make_equiv.
-  rapply (contr_equiv' { X : Type &  A <~> X }).
+  rapply (contr_equiv' { X : Type@{u} &  A <~> X }).
   nrapply equiv_functor_sigma_id; intro X; symmetry.
   rapply equiv_sigma_contr.
   (** If you replace the type in the second line with { Xf : {X : Type & A <~> X} & {x : Xf.1 & Xf.2 pt = x} }, then the third line completes the proof, but that results in an extra universe variable. *)
@@ -958,14 +1012,11 @@ Defined.
 
 Global Instance hasmorext_core_ptype `{Funext} : HasMorExt (core pType).
 Proof.
-  snrapply Build_HasMorExt.
-  intros a b f g.
-  unfold GpdHom_path.
-  cbn in f, g.
-  (* [GpdHom_path] and the inverse of [equiv_path_pequiv] are not definitionally equal, but they compute to definitionally equal things on [idpath]. *)
-  apply (isequiv_homotopic (equiv_path_pequiv f g)^-1%equiv).
-  intro p; induction p; cbn.
-  reflexivity.
+  rapply hasmorext_core.
+  intros A B f g.
+  snrapply isequiv_homotopic'.
+  1: exact (equiv_path_pequiv' f g)^-1%equiv.
+  by intros [].
 Defined.
 
 (** pType is a univalent 1-coherent 1-category *)
@@ -1018,5 +1069,25 @@ Lemma natequiv_pointify_r `{Funext} (A : Type)
 Proof.
   snrapply Build_NatEquiv.
   1: rapply equiv_pointify_map.
+  snrapply Build_Is1Natural.
   cbv; reflexivity.
 Defined.
+
+(** * Pointed categories give rise to pointed structures *)
+
+(** Pointed categories have pointed hom sets *)
+Definition pHom {A : Type} `{IsPointedCat A} (a1 a2 : A)
+  := [Hom a1 a2, zero_morphism].
+
+(** Pointed functors give pointed maps on morphisms *)
+Definition pfmap {A B : Type} (F : A -> B)
+  `{IsPointedCat A, IsPointedCat B, !HasEquivs B, !HasMorExt B}
+  `{!Is0Functor F, !Is1Functor F, !IsPointedFunctor F}
+  {a1 a2 : A}
+  : pHom a1 a2 ->* pHom (F a1) (F a2).
+Proof.
+  snrapply Build_pMap.
+  - exact (fmap F).
+  - apply path_hom.
+    snrapply fmap_zero_morphism; assumption.
+Defined.
diff --git a/theories/Pointed/Loops.v b/theories/Pointed/Loops.v
index 3870802d073..7feee4dfb31 100644
--- a/theories/Pointed/Loops.v
+++ b/theories/Pointed/Loops.v
@@ -428,6 +428,7 @@ Defined.
 (** [loops_inv] is a natural transformation. *)
 Global Instance is1natural_loops_inv : Is1Natural loops loops loops_inv.
 Proof.
+  snrapply Build_Is1Natural.
   intros A B f.
   srapply Build_pHomotopy.
   + intros p. refine (inv_Vp _ _ @ whiskerR _ (point_eq f) @ concat_pp_p _ _ _).
diff --git a/theories/Pointed/pFiber.v b/theories/Pointed/pFiber.v
index 92558e3cff7..144b2bf258f 100644
--- a/theories/Pointed/pFiber.v
+++ b/theories/Pointed/pFiber.v
@@ -20,12 +20,10 @@ Definition pfib {A B : pType} (f : A ->* B) : pfiber f ->* A
 Definition pfiber2_loops {A B : pType} (f : A ->* B)
   : pfiber (pfib f) <~>* loops B.
 Proof.
+  pointed_reduce_pmap f.
   snrapply Build_pEquiv'.
-  { transitivity (f (point A) = point B).
-    1: make_equiv_contr_basedpaths.
-    apply equiv_concat_l.
-    symmetry; apply point_eq. }
-  cbn; apply concat_Vp.
+  1: make_equiv_contr_basedpaths.
+  reflexivity.
 Defined.
 
 Definition pfiber_fmap_loops {A B : pType} (f : A ->* B)
diff --git a/theories/Pointed/pModality.v b/theories/Pointed/pModality.v
index d3c9ba02338..36d340b2000 100644
--- a/theories/Pointed/pModality.v
+++ b/theories/Pointed/pModality.v
@@ -1,4 +1,4 @@
-Require Import Basics Types ReflectiveSubuniverse Pointed.Core Pointed.pEquiv.
+Require Import Basics Types ReflectiveSubuniverse Pointed.Core.
 
 Local Open Scope pointed_scope.
 
diff --git a/theories/Pointed/pSusp.v b/theories/Pointed/pSusp.v
index 815153c077b..b1d302e691c 100644
--- a/theories/Pointed/pSusp.v
+++ b/theories/Pointed/pSusp.v
@@ -91,10 +91,7 @@ Module Book_Loop_Susp_Adjunction.
     refine (_ oE (equiv_sigma_contr
                    (A := {p : B & A -> point B = p})
                    (fun pm => { q : point B = pm.1 & pm.2 (point A) = q }))^-1).
-    transitivity {bp : {b:B & point B = b} & {f : A -> point B = bp.1 & f (point A) = bp.2} }.
-    1:make_equiv.
-    refine (_ oE equiv_contr_sigma _); simpl.
-    refine (issig_pmap A (loops B)).
+    make_equiv_contr_basedpaths.
   Defined.
 
   (** Unfortunately, with this definition it seems to be quite hard to prove that the isomorphism is natural on pointed maps.  The following proof gets partway there, but ends with a pretty intractable goal.  It's also quite slow, so we don't want to compile it all the time. *)
@@ -295,6 +292,7 @@ Global Instance is1natural_loop_susp_adjoint_r `{Funext} (A : pType)
   : Is1Natural (opyon (psusp A)) (opyon A o loops)
       (loop_susp_adjoint A).
 Proof.
+  snrapply Build_Is1Natural.
   intros B B' g f.
   refine ( _ @ cat_assoc_strong _ _ _).
   refine (ap (fun x => x o* loop_susp_unit A) _).
diff --git a/theories/Pointed/pTrunc.v b/theories/Pointed/pTrunc.v
index 3e93c5218c5..cef040364cb 100644
--- a/theories/Pointed/pTrunc.v
+++ b/theories/Pointed/pTrunc.v
@@ -148,6 +148,15 @@ Proof.
     reflexivity.
 Defined.
 
+(** Pointed truncation preserves binary products. *)
+Definition pequiv_ptr_prod (n : trunc_index) (A B : pType)
+  : pTr n (A * B) <~>* pTr n A * pTr n B.
+Proof.
+  snrapply Build_pEquiv'.
+  1: nrapply equiv_Trunc_prod_cmp.
+  reflexivity.
+Defined.
+
 (** ** Truncatedness of [pForall] and [pMap] *)
 
 (** Buchholtz-van Doorn-Rijke, Theorem 4.2:  Let [j >= -1] and [n >= -2].  When [X] is [j]-connected and [Y] is a pointed family of [j+k+1]-truncated types, the type of pointed sections is [n]-truncated.  We formalize it with [j] replaced with a trunc index [m], and so there is a shift compared to the informal statement. This version also allows [n] to be one smaller than BvDR allow. *)
@@ -166,7 +175,7 @@ Definition istrunc_pmap `{Univalence} {m n : trunc_index} (X Y : pType)
   : IsTrunc n (X ->* Y)
   := istrunc_pforall X (pfam_const Y).
 
-(** We can give a different proof of the [n = -1] case (with the conclusion upgraded to contractibility).  This proof works for any reflective subuniverse and avoids univalence.  Is it possible to generalize this to dependent functions while still avoiding univalence and/or keeping [O] a general RSU or modality?  Can [istrunc_pmap] be proven without univalence?  What about [istrunc_pforall]?  If the [n = -2] or [n = -1] cases can be provied without univalence, the rest can be done inductively without univalence. *)
+(** We can give a different proof of the [n = -1] case (with the conclusion upgraded to contractibility).  This proof works for any reflective subuniverse and avoids univalence.  Is it possible to generalize this to dependent functions while still avoiding univalence and/or keeping [O] a general RSU or modality?  Can [istrunc_pmap] be proven without univalence?  What about [istrunc_pforall]?  If the [n = -2] or [n = -1] cases can be proven without univalence, the rest can be done inductively without univalence. *)
 Definition contr_pmap_isconnected_inO `{Funext} (O : ReflectiveSubuniverse)
   (X : pType) `{IsConnected O X} (Y : pType) `{In O Y}
   : Contr (X ->* Y).
@@ -174,3 +183,8 @@ Proof.
   srapply (contr_equiv' ([O X, _] ->* Y)).
   rapply pequiv_o_pto_O.
 Defined.
+
+(** Every pointed type is (-1)-connected. *)
+Global Instance is_minus_one_connected_pointed (X : pType)
+  : IsConnected (Tr (-1)) X
+  := contr_inhabited_hprop _ (tr pt).
diff --git a/theories/PropResizing/ImpredicativeTruncation.v b/theories/PropResizing/ImpredicativeTruncation.v
index dc83e8cc104..9adbb46f105 100644
--- a/theories/PropResizing/ImpredicativeTruncation.v
+++ b/theories/PropResizing/ImpredicativeTruncation.v
@@ -1,7 +1,7 @@
 (* -*- mode: coq; mode: visual-line -*-  *)
 (** * Impredicative truncations. *)
 
-Require Import HoTT.Basics HoTT.Types.
+Require Import HoTT.Basics.
 Require Import PropResizing.PropResizing.
 Local Open Scope path_scope.
 
diff --git a/theories/PropResizing/Nat.v b/theories/PropResizing/Nat.v
index 4a912a322bd..6b71aa35cfc 100644
--- a/theories/PropResizing/Nat.v
+++ b/theories/PropResizing/Nat.v
@@ -149,8 +149,7 @@ Section AssumeStuff.
     Qed.
 
     Definition graph_unsucc_equiv_vert@{} : vert A <~> vert B
-      := equiv_unfunctor_sum_l@{s s s s s  s Set Set Set Set}
-                              f Ha Hb.
+      := equiv_unfunctor_sum_l@{s s s s s s} f Ha Hb.
 
     Definition graph_unsucc_equiv_edge@{} (x y : vert A)
       : iff@{s s s} (edge A x y) (edge B (graph_unsucc_equiv_vert x) (graph_unsucc_equiv_vert y)).
@@ -364,8 +363,7 @@ Section AssumeStuff.
   Proof.
     intros [n nrec].
     pose (Q := fun m:Graph => forall (mrec : in_N m), P (m;mrec)).
-    (* The try clause below is only needed for Coq <= 8.11 *)
-    refine (resize_nrec n nrec Q _ _ _ nrec);clear n nrec; try (intros A; apply trunc_forall).
+    refine (resize_nrec n nrec Q _ _ _ nrec); clear n nrec.
     - intros zrec.
       refine (transport P _ P0).
       apply ap.
@@ -376,9 +374,6 @@ Section AssumeStuff.
       apply path_N; reflexivity.
   Qed.
 
-  (** Sometimes we just need a bigger fish. *)
-  Universe large.
-
   (** A first application *)
   Definition N_neq_succ@{} (n : N) : n <> succ n.
   Proof.
@@ -795,7 +790,7 @@ Section AssumeStuff.
       - refine (_ oE equiv_inverse (equiv_sigma_assoc _ _)).
         apply equiv_functor_sigma_id; intros f.
         cbn; apply equiv_sigma_prod0.
-      - refine (@istrunc_sigma@{nr nr large nr} _ _ _ _ _).
+      - refine (@istrunc_sigma@{nr nr nr} _ _ _ _ _).
         + srefine (Build_Contr _ _ _).
           * exists (fun _ => x0); reflexivity.
           * intros [g H].
diff --git a/theories/Sets/AC.v b/theories/Sets/AC.v
index 1742cd67928..5a770400e68 100644
--- a/theories/Sets/AC.v
+++ b/theories/Sets/AC.v
@@ -1,4 +1,4 @@
-From HoTT Require Import ExcludedMiddle abstract_algebra.
+From HoTT Require Import ExcludedMiddle canonical_names.
 From HoTT Require Import HIT.unique_choice.
 From HoTT Require Import Spaces.Card.
 
diff --git a/theories/Sets/Ordinals.v b/theories/Sets/Ordinals.v
index 39c2a4bff77..fc3826b381b 100644
--- a/theories/Sets/Ordinals.v
+++ b/theories/Sets/Ordinals.v
@@ -1,6 +1,7 @@
 From HoTT Require Import TruncType ExcludedMiddle Modalities.ReflectiveSubuniverse abstract_algebra.
 From HoTT Require Import PropResizing.PropResizing.
 From HoTT Require Import Colimits.Quotient.
+From HoTT Require Import HSet.
 
 Local Open Scope hprop_scope.
 
@@ -742,58 +743,25 @@ Qed.
 
 (** * Ordinal limit *)
 
-(** We can use PropResizing to resize the image of a function to whatever universe we want. *)
-Definition image@{i j |} `{PropResizing} {A : Type@{i}} {B : HSet@{j}} (f : A -> B) : Type@{i}
-  := Quotient@{i i i} (fun a a' : A => resize_hprop@{j i} (f a = f a')).
+Section Image.
 
-Definition factor1 `{PropResizing} {A} {B : HSet} (f : A -> B)
-  : A -> image f
-  := Quotient.class_of _.
+  Universes i j.
+  (** In the following, there are no constraints between [i] and [j]. *)
+  Context `{PropResizing} `{Funext} {A : Type@{i}} {B : HSet@{j}} (f : A -> B).
 
-Lemma image_ind_prop@{i j k|} `{PropResizing} {A : Type@{i}} {B : HSet@{j}} (f : A -> B)
-  (P : image f -> Type@{k}) `{forall x, IsHProp (P x)}
-  : (forall a : A, P (factor1 f a))
-    -> forall x : image f, P x.
-Proof.
-  intros step.
-  srefine (Quotient_ind_hprop _ _ _); intros a; cbn.
-  apply step.
-Qed.
-
-Definition image_rec@{i j k|} `{PropResizing} {A : Type@{i}} {B : HSet@{j}} (f : A -> B)
-      {C : HSet@{k}} (step : A -> C)
-  (p : forall a a', f a = f a' -> step a = step a')
-  : image f -> C.
-Proof.
-  snrapply Quotient_rec.
-  - exact _.
-  - exact step.
-  - simpl. intros x y q.
-    apply p.
-    apply (equiv_resize_hprop _)^-1.
-    exact q.
-Defined.
+  Local Definition qkfs := quotient_kernel_factor_small f.
+  Local Definition image : Type@{i} := qkfs.1.
+  Local Definition factor1 : A -> image := qkfs.2.1.
+  Local Definition factor2 : image -> B := qkfs.2.2.1.
+  Local Definition isinjective_factor2 : IsInjective factor2
+    := isinj_embedding _ (snd (fst qkfs.2.2.2)).
+  Local Definition image_ind_prop (P : image -> Type@{k}) `{forall x, IsHProp (P x)}
+    (step : forall a : A, P (factor1 a))
+    : forall x : image, P x
+    := Quotient_ind_hprop _ P step.
+  (** [factor2 o factor1 == f] is definitional, so we don't state that. *)
 
-Definition factor2@{i j|} `{PropResizing} {A : Type@{i}} {B : HSet@{j}} (f : A -> B)
-  : image f -> B.
-Proof.
-  snrapply image_rec.
-  - exact f.
-  - intros a a' fa_fa'.
-    apply fa_fa'.
-Defined.
-
-Global Instance isinjective_factor2 `{PropResizing} `{Funext} {A} {B : HSet} (f : A -> B)
-  : IsInjective (factor2 f).
-Proof.
-  unfold IsInjective, image.
-  refine (Quotient_ind_hprop _ _ _); intros x; cbn.
-  refine (Quotient_ind_hprop _ _ _); intros y; cbn.
-  simpl; intros p.
-  rapply qglue.
-  apply equiv_resize_hprop.
-  exact p.
-Qed.
+End Image.
 
 Definition limit `{Univalence} `{PropResizing}
            {X : Type} (F : X -> Ordinal) : Ordinal.
@@ -804,16 +772,20 @@ Proof.
                      resize_hprop (factor2 f A < factor2 f B)
                      : Type@{i}).
   exists carrier relation.
-  srapply (isordinal_simulation (factor2 f)).
-  - exact _.
-  - exact _.
-  - constructor; cbn.
+  snrapply (isordinal_simulation (factor2 f)).
+  1-4: exact _.
+  - apply isinjective_factor2.
+  - constructor.
     + intros x x' x_x'.
       unfold lt, relation. apply equiv_resize_hprop in x_x'. exact x_x'.
-    + rapply image_ind_prop; intros a. cbn.
+    + nrefine (image_ind_prop f _ _). 1: exact _.
+      intros a.
+      change (factor2 f (class_of _ a)) with (f a).
       intros B B_fa. apply tr.
-      exists (factor1 f (a.1; out (bound B_fa))). cbn.
-      unfold lt, relation, f; simpl.
+      exists (factor1 f (a.1; out (bound B_fa))).
+      unfold lt, relation.
+      change (factor2 f (factor1 f ?A)) with (f A).
+      unfold f.
       assert (↓(out (bound B_fa)) = B) as ->. {
         rewrite (path_initial_segment_simulation out).
         symmetry. apply bound_property.
@@ -830,17 +802,24 @@ Definition limit_is_upper_bound `{Univalence} `{PropResizing}
            {X : Type} (F : X -> Ordinal)
   : forall x, F x <= limit F.
 Proof.
-  unfold le_on_Ordinal.
-  intros x. unfold le.
-  exists (fun u => factor1 _ (x; u)).
+  set (f := fun x : {i : X & F i} => ↓x.2).
+  intros x. unfold le, le_on_Ordinal.
+  exists (fun u => factor1 f (x; u)).
   split.
-  - intros u v u_v. unfold lt; cbn. apply equiv_resize_hprop.
+  - intros u v u_v.
+    change (resize_hprop (f (x; u) < f (x; v))).
+    apply equiv_resize_hprop.
     apply isembedding_initial_segment. exact u_v.
-  - intros u. rapply image_ind_prop; intros a.
-    intros a_u. apply equiv_resize_hprop in a_u. cbn in a_u.
+  - intros u.
+    nrefine (image_ind_prop f _ _). 1: exact _.
+    intros a a_u.
+    change (resize_hprop (f a < f (x; u))) in a_u.
+    apply equiv_resize_hprop in a_u.
     apply tr. exists (out (bound a_u)). split.
     + apply initial_segment_property.
-    + apply (injective (factor2 _)); simpl.
+    + apply (isinjective_factor2 f); simpl.
+      change (factor2 f (factor1 f ?A)) with (f A).
+      unfold f.
       rewrite (path_initial_segment_simulation out).
       symmetry. apply bound_property.
 Qed.
diff --git a/theories/Spaces/BAut/Cantor.v b/theories/Spaces/BAut/Cantor.v
index 47e26b80e93..c624110fc27 100644
--- a/theories/Spaces/BAut/Cantor.v
+++ b/theories/Spaces/BAut/Cantor.v
@@ -20,7 +20,7 @@ Section Assumptions.
   Proof.
     intros Z.
     (** Here is the important part of this definition. *)
-    exists (Z + Cantor)%type.
+    exists (Z + Cantor).
     (** The rest is just a proof that [Z+Cantor] is again equivalent to [Cantor], using [cantor_fold] and the assumption that [Z] is equivalent to [Cantor]. *)
     pose (e := Z.2); simpl in e; clearbody e.
     strip_truncations.
diff --git a/theories/Spaces/BinInt.v b/theories/Spaces/BinInt.v
new file mode 100644
index 00000000000..75460b248e6
--- /dev/null
+++ b/theories/Spaces/BinInt.v
@@ -0,0 +1,4 @@
+Require Export HoTT.Spaces.BinInt.Core.
+Require Export HoTT.Spaces.BinInt.Spec.
+Require Export HoTT.Spaces.BinInt.Equiv.
+Require Export HoTT.Spaces.BinInt.LoopExp.
diff --git a/theories/Spaces/Int/Core.v b/theories/Spaces/BinInt/Core.v
similarity index 66%
rename from theories/Spaces/Int/Core.v
rename to theories/Spaces/BinInt/Core.v
index 17805667520..11f16d3fbf1 100644
--- a/theories/Spaces/Int/Core.v
+++ b/theories/Spaces/BinInt/Core.v
@@ -3,7 +3,7 @@ Require Import Spaces.Pos.Core.
 
 Local Set Universe Minimization ToSet.
 
-(** * The Integers. *)
+(** * Binary Integers *)
 
 Local Close Scope trunc_scope.
 Local Close Scope nat_scope.
@@ -13,17 +13,19 @@ Local Open Scope positive_scope.
 (** ** Definition of the Integers *)
 
 (** We define an integer as being a positive number labelled negative, zero or a positive number labelled positive. *)
-Inductive Int : Type0 :=
-  | neg : Pos -> Int
-  | zero : Int
-  | pos : Pos -> Int.
+Inductive BinInt : Type0 :=
+  | neg : Pos -> BinInt
+  | zero : BinInt
+  | pos : Pos -> BinInt.
 
-Declare Scope int_scope.
-Local Open Scope int_scope.
-Delimit Scope int_scope with int.
+Arguments pos p%_pos.
+
+Declare Scope binint_scope.
+Local Open Scope binint_scope.
+Delimit Scope binint_scope with binint.
 
 (** The integers are a pointed type *)
-Global Instance ispointed_Int : IsPointed Int := zero.
+Global Instance ispointed_BinInt : IsPointed BinInt := zero.
 
 (** Properties of constructors *)
 
@@ -55,20 +57,20 @@ Definition pos_neq_neg {z w : Pos} := @neg_neq_pos z w o symmetry _ _.
 
 (** ** Conversion with a decimal representation for printing/parsing *)
 
-Definition int_to_decimal_int (n : Int) : Decimal.int :=
+Definition binint_to_decimal_binint (n : BinInt) : Decimal.int :=
   match n with
     | neg m => Decimal.Neg (pos_to_uint m)
     | zero  => Decimal.Pos Decimal.Nil
     | pos m => Decimal.Pos (pos_to_uint m)
   end.
 
-Definition int_to_number_int (n : Int) : Numeral.int :=
-  Numeral.IntDec (int_to_decimal_int n).
+Definition binint_to_number_binint (n : BinInt) : Numeral.int :=
+  Numeral.IntDec (binint_to_decimal_binint n).
 
-Fixpoint int_of_decimal_uint (d : Decimal.uint) : Int :=
+Fixpoint binint_of_decimal_uint (d : Decimal.uint) : BinInt :=
   match d with
     | Decimal.Nil => zero
-    | Decimal.D0 l => int_of_decimal_uint l
+    | Decimal.D0 l => binint_of_decimal_uint l
     | Decimal.D1 l => pos (pos_of_uint_acc l 1)
     | Decimal.D2 l => pos (pos_of_uint_acc l 1~0)
     | Decimal.D3 l => pos (pos_of_uint_acc l 1~1)
@@ -80,59 +82,59 @@ Fixpoint int_of_decimal_uint (d : Decimal.uint) : Int :=
     | Decimal.D9 l => pos (pos_of_uint_acc l 1~0~0~1)
   end.
 
-Definition int_of_decimal_int (d : Decimal.int) : Int :=
+Definition binint_of_decimal_binint (d : Decimal.int) : BinInt :=
   match d with
-    | Decimal.Pos u => int_of_decimal_uint u
-    | Decimal.Neg u => let t := int_of_decimal_uint u in
+    | Decimal.Pos u => binint_of_decimal_uint u
+    | Decimal.Neg u => let t := binint_of_decimal_uint u in
         match t with
           | pos v => neg v
           | _ => zero
         end
   end.
 
-Definition int_of_number_int (d:Numeral.int) :=
+Definition binint_of_number_binint (d:Numeral.int) :=
   match d with
-  | Numeral.IntDec d => Some (int_of_decimal_int d)
+  | Numeral.IntDec d => Some (binint_of_decimal_binint d)
   | Numeral.IntHex _ => None
   end.
 
-Number Notation Int int_of_number_int int_to_number_int : int_scope.
+Number Notation BinInt binint_of_number_binint binint_to_number_binint : binint_scope.
 
 (* For some reason 0 can be parsed as an integer, but is printed as [zero]. This notation fixes that. *)
-Notation "0" := zero : int_scope.
+Notation "0" := zero : binint_scope.
 
 (** ** Doubling and variants *)
 
-Definition int_double x :=
+Definition binint_double x :=
   match x with
     | 0 => 0
     | pos p => pos p~0
     | neg p => neg p~0
   end.
 
-Definition int_succ_double x :=
+Definition binint_succ_double x :=
   match x with
     | 0 => 1
     | pos p => pos p~1
     | neg p => neg (pos_pred_double p)
   end.
 
-Definition int_pred_double x :=
+Definition binint_pred_double x :=
   match x with
     | 0 => neg 1%pos
     | neg p => neg p~1
     | pos p => pos (pos_pred_double p)
   end.
 
-(** ** Subtraction of positive into Int *)
+(** ** Subtraction of positive into BinInt *)
 
-Fixpoint int_pos_sub (x y : Pos) {struct y} : Int :=
+Fixpoint binint_pos_sub (x y : Pos) {struct y} : BinInt :=
   match x, y with
-    | p~1, q~1 => int_double (int_pos_sub p q)
-    | p~1, q~0 => int_succ_double (int_pos_sub p q)
+    | p~1, q~1 => binint_double (binint_pos_sub p q)
+    | p~1, q~0 => binint_succ_double (binint_pos_sub p q)
     | p~1, 1 => pos p~0
-    | p~0, q~1 => int_pred_double (int_pos_sub p q)
-    | p~0, q~0 => int_double (int_pos_sub p q)
+    | p~0, q~1 => binint_pred_double (binint_pos_sub p q)
+    | p~0, q~0 => binint_double (binint_pos_sub p q)
     | p~0, 1 => pos (pos_pred_double p)
     | 1, q~1 => neg q~0
     | 1, q~0 => neg (pos_pred_double q)
@@ -141,51 +143,51 @@ Fixpoint int_pos_sub (x y : Pos) {struct y} : Int :=
 
 (** ** Negation *)
 
-Definition int_negation x :=
+Definition binint_negation x :=
   match x with
     | zero => zero
     | pos x => neg x
     | neg x => pos x
   end.
 
-Notation "- x" := (int_negation x) : int_scope.
+Notation "- x" := (binint_negation x) : binint_scope.
 
-Lemma int_negation_negation n : --n = n.
+Lemma ibnint_negation_negation n : --n = n.
 Proof.
   by destruct n.
 Qed.
 
 (** ** Addition *)
 
-Definition int_add x y :=
+Definition binint_add x y :=
   match x, y with
     | 0, y => y
     | x, 0 => x
     | pos x', pos y' => pos (x' + y')
-    | pos x', neg y' => int_pos_sub x' y'
-    | neg x', pos y' => int_pos_sub y' x'
+    | pos x', neg y' => binint_pos_sub x' y'
+    | neg x', pos y' => binint_pos_sub y' x'
     | neg x', neg y' => neg (x' + y')
   end.
 
-Infix "+" := int_add : int_scope.
+Infix "+" := binint_add : binint_scope.
 
 (** ** Successor *)
 
-Definition int_succ x := x + 1.
+Definition binint_succ x := x + 1.
 
 (** ** Predecessor *)
 
-Definition int_pred x := x + neg 1%pos.
+Definition binint_pred x := x + neg 1%pos.
 
 (** ** Subtraction *)
 
-Definition int_sub m n := m + -n.
+Definition binint_sub m n := m + -n.
 
-Infix "-" := int_sub : int_scope.
+Infix "-" := binint_sub : binint_scope.
 
 (** ** Multiplication *)
 
-Definition int_mul x y :=
+Definition binint_mul x y :=
   match x, y with
     | 0, _ => 0
     | _, 0 => 0
@@ -195,22 +197,22 @@ Definition int_mul x y :=
     | neg x', neg y' => pos (x' * y')
   end.
 
-Infix "*" := int_mul : int_scope.
+Infix "*" := binint_mul : binint_scope.
 
 (** ** Power function *)
 
-Definition int_pow x y :=
+Definition binint_pow x y :=
   match y with
-    | pos p => pos_iter (int_mul x) p 1
+    | pos p => pos_iter (binint_mul x) p 1
     | 0 => 1
     | neg _ => 0
   end.
 
-Infix "^" := int_pow : int_scope.
+Infix "^" := binint_pow : binint_scope.
 
 (** ** Square *)
 
-Definition int_square x :=
+Definition binint_square x :=
   match x with
     | 0 => 0
     | pos p => pos (pos_square p)
@@ -219,7 +221,7 @@ Definition int_square x :=
 
 (** ** Sign function *)
 
-Definition sgn z :=
+Definition binint_sgn z :=
   match z with
     | 0 => 0
     | pos p => 1
@@ -228,7 +230,7 @@ Definition sgn z :=
 
 (* ** Decidable paths and truncation. *)
 
-Global Instance decpaths_int : DecidablePaths Int.
+Global Instance decpaths_binint : DecidablePaths BinInt.
 Proof.
   intros [n | | n] [m | | m].
   + destruct (dec (n = m)) as [p | q].
@@ -247,4 +249,4 @@ Proof.
 Defined.
 
 (** Since integers have decidable paths they are a hset *)
-Global Instance hset_int : IsHSet Int | 0 := _.
+Global Instance hset_binint : IsHSet BinInt | 0 := _.
diff --git a/theories/Spaces/Int/Equiv.v b/theories/Spaces/BinInt/Equiv.v
similarity index 56%
rename from theories/Spaces/Int/Equiv.v
rename to theories/Spaces/BinInt/Equiv.v
index c47a67064fd..dbadec793aa 100644
--- a/theories/Spaces/Int/Equiv.v
+++ b/theories/Spaces/BinInt/Equiv.v
@@ -1,13 +1,13 @@
 Require Import Basics.
 Require Import Spaces.Pos.
-Require Import Spaces.Int.Core.
-Require Import Spaces.Int.Spec.
+Require Import Spaces.BinInt.Core.
+Require Import Spaces.BinInt.Spec.
 
 (** ** Iteration of equivalences *)
 
 (** *** Iteration by arbitrary integers *)
 
-Definition int_iter {A} (f : A -> A) `{!IsEquiv f} (n : Int) : A -> A
+Definition binint_iter {A} (f : A -> A) `{!IsEquiv f} (n : BinInt) : A -> A
   := match n with
       | neg n => fun x => pos_iter f^-1 n x
       | zero => idmap
@@ -17,9 +17,9 @@ Definition int_iter {A} (f : A -> A) `{!IsEquiv f} (n : Int) : A -> A
 (** Iteration by arbitrary integers requires the endofunction to be an equivalence, so that we can define a negative iteration by using its inverse. *)
 
 
-Definition int_iter_succ_l {A} (f : A -> A) `{IsEquiv _ _ f}
-  (n : Int) (a : A)
-  : int_iter f (int_succ n) a = f (int_iter f n a).
+Definition binint_iter_succ_l {A} (f : A -> A) `{IsEquiv _ _ f}
+  (n : BinInt) (a : A)
+  : binint_iter f (binint_succ n) a = f (binint_iter f n a).
 Proof.
   destruct n as [n| |n]; trivial.
   + revert n f H a.
@@ -29,8 +29,8 @@ Proof.
       apply eisretr. }
     hnf; intros n p f H a.
     refine (ap (fun x => _ x _) _ @ _).
-    1: rewrite int_neg_pos_succ.
-    1: exact (eisretr int_succ (neg n)).
+    1: rewrite binint_neg_pos_succ.
+    1: exact (eisretr binint_succ (neg n)).
     apply moveL_equiv_M.
     cbn; symmetry.
     srapply pos_iter_succ_l.
@@ -39,8 +39,8 @@ Proof.
     srapply pos_iter_succ_l.
 Qed.
 
-Definition int_iter_succ_r {A} (f : A -> A) `{IsEquiv _ _ f}
-  (n : Int) (a : A) : int_iter f (int_succ n) a = int_iter f n (f a).
+Definition binint_iter_succ_r {A} (f : A -> A) `{IsEquiv _ _ f}
+  (n : BinInt) (a : A) : binint_iter f (binint_succ n) a = binint_iter f n (f a).
 Proof.
    destruct n as [n| |n]; trivial.
 + revert n f H a.
@@ -49,9 +49,9 @@ Proof.
     symmetry.
     apply eissect. }
   hnf; intros n p f H a.
-  rewrite int_neg_pos_succ.
+  rewrite binint_neg_pos_succ.
   refine (ap (fun x => _ x _) _ @ _).
-  1: exact (eisretr int_succ (neg n)).
+  1: exact (eisretr binint_succ (neg n)).
   cbn; rewrite pos_add_1_r.
   rewrite pos_iter_succ_r.
   rewrite eissect.
@@ -61,9 +61,9 @@ Proof.
   srapply pos_iter_succ_r.
 Qed.
 
-Definition iter_int_pred_l {A} (f : A -> A) `{IsEquiv _ _ f}
-  (n : Int) (a : A)
-: int_iter f (int_pred n) a = f^-1 (int_iter f n a).
+Definition iter_binint_pred_l {A} (f : A -> A) `{IsEquiv _ _ f}
+  (n : BinInt) (a : A)
+: binint_iter f (binint_pred n) a = f^-1 (binint_iter f n a).
 Proof.
   destruct n as [n| |n]; trivial.
   + cbn; rewrite pos_add_1_r.
@@ -73,19 +73,19 @@ Proof.
     - cbn; symmetry; apply eissect.
     - hnf; intros p q.
       rewrite <- pos_add_1_r.
-      change (int_pred (pos (p + 1)%pos))
-        with (int_pred (int_succ (pos p))).
-      rewrite int_pred_succ.
+      change (binint_pred (pos (p + 1)%pos))
+        with (binint_pred (binint_succ (pos p))).
+      rewrite binint_pred_succ.
       change (pos (p + 1)%pos)
-        with (int_succ (pos p)).
-      rewrite int_iter_succ_l.
+        with (binint_succ (pos p)).
+      rewrite binint_iter_succ_l.
       symmetry.
       apply eissect.
 Qed.
 
-Definition iter_int_pred_r {A} (f : A -> A) `{IsEquiv _ _ f}
-  (n : Int) (a : A)
-: int_iter f (int_pred n) a = int_iter f n (f^-1 a).
+Definition iter_binint_pred_r {A} (f : A -> A) `{IsEquiv _ _ f}
+  (n : BinInt) (a : A)
+: binint_iter f (binint_pred n) a = binint_iter f n (f^-1 a).
 Proof.
   revert f H n a.
   destruct n as [n| |n]; trivial;
@@ -93,12 +93,12 @@ Proof.
   2: hnf; intros; apply symmetry, eisretr.
   all: rewrite <- pos_add_1_r.
   all: intro a.
-  1: change (neg (n + 1)%pos) with (int_pred (neg n)).
-  2: change (pos (n + 1)%pos) with (int_succ (pos n)).
-  1: rewrite <- 2 int_neg_pos_succ.
+  1: change (neg (n + 1)%pos) with (binint_pred (neg n)).
+  2: change (pos (n + 1)%pos) with (binint_succ (pos n)).
+  1: rewrite <- 2 binint_neg_pos_succ.
   1: cbn; apply pos_iter_succ_r.
-  rewrite int_pred_succ.
-  rewrite int_iter_succ_r.
+  rewrite binint_pred_succ.
+  rewrite binint_iter_succ_r.
   rewrite eisretr.
   reflexivity.
 Qed.
diff --git a/theories/Spaces/Int/LoopExp.v b/theories/Spaces/BinInt/LoopExp.v
similarity index 80%
rename from theories/Spaces/Int/LoopExp.v
rename to theories/Spaces/BinInt/LoopExp.v
index 34f23f8da38..5420dc88de2 100644
--- a/theories/Spaces/Int/LoopExp.v
+++ b/theories/Spaces/BinInt/LoopExp.v
@@ -1,12 +1,12 @@
 Require Import Basics.
 Require Import Types.Universe.
 Require Import Spaces.Pos.
-Require Import Spaces.Int.Core.
-Require Import Spaces.Int.Spec.
-Require Import Spaces.Int.Equiv.
+Require Import Spaces.BinInt.Core.
+Require Import Spaces.BinInt.Spec.
+Require Import Spaces.BinInt.Equiv.
 
 Local Open Scope positive_scope.
-Local Open Scope int_scope.
+Local Open Scope binint_scope.
 
 (** ** Exponentiation of loops *)
 
@@ -19,14 +19,14 @@ Proof.
     exact (q @ p).
 Defined.
 
-Definition loopexp {A : Type} {x : A} (p : x = x) (z : Int) : (x = x)
+Definition loopexp {A : Type} {x : A} (p : x = x) (z : BinInt) : (x = x)
   := match z with
        | neg n => loopexp_pos p^ n
        | zero => 1
        | pos n => loopexp_pos p n
      end.
 
-(** TODO: One can also define [loopexp] as [int_iter (equiv_concat_r p x) z idpath].  This has slightly different computational behaviour, e.g., it sends [1 : int] to [1 @ p] rather than [p].  But with this definition, some of the results below become special cases of results in Int.Equiv, and others could be generalized to results belonging in Int.Equiv.  It's probably worth investigating this. *)
+(** TODO: One can also define [loopexp] as [int_iter (equiv_concat_r p x) z idpath].  This has slightly different computational behaviour, e.g., it sends [1 : int] to [1 @ p] rather than [p].  But with this definition, some of the results below become special cases of results in BinInt.Equiv, and others could be generalized to results belonging in BinInt.Equiv.  It's probably worth investigating this. *)
 
 Lemma loopexp_pos_inv {A : Type} {x : A} (p : x = x) (n : Pos)
   : loopexp_pos p^ n = (loopexp_pos p n)^.
@@ -56,7 +56,7 @@ Proof.
   by rewrite ap_pp, q.
 Qed.
 
-Definition ap_loopexp {A B} (f : A -> B) {x : A} (p : x = x) (z : Int)
+Definition ap_loopexp {A B} (f : A -> B) {x : A} (p : x = x) (z : BinInt)
 : ap f (loopexp p z) = loopexp (ap f p) z.
 Proof.
   destruct z as [n| |n]; trivial.
@@ -103,58 +103,58 @@ Proof.
 Qed.
 
 
-Lemma loopexp_int_pos_sub_l {A : Type} {x : A} (p : x = x) (a b : Pos)
-  : loopexp p (int_pos_sub a b) = loopexp_pos p^ b @ loopexp_pos p a.
+Lemma loopexp_binint_pos_sub_l {A : Type} {x : A} (p : x = x) (a b : Pos)
+  : loopexp p (binint_pos_sub a b) = loopexp_pos p^ b @ loopexp_pos p a.
 Proof.
   symmetry.
   revert a b.
   induction a as [|a aH] using pos_peano_ind;
   induction b as [|b bH] using pos_peano_ind.
   + apply concat_Vp.
-  + cbn; rewrite int_pos_sub_succ_r.
+  + cbn; rewrite binint_pos_sub_succ_r.
     unfold loopexp_pos.
     rewrite pos_peano_ind_beta_pos_succ.
     by rewrite concat_pp_p, concat_Vp, concat_p1.
-  + rewrite int_pos_sub_succ_l; cbn.
+  + rewrite binint_pos_sub_succ_l; cbn.
     unfold loopexp_pos.
     rewrite pos_peano_ind_beta_pos_succ.
     rewrite loopexp_pos_concat.
     by rewrite concat_p_pp, concat_Vp, concat_1p.
-  + rewrite int_pos_sub_succ_succ.
+  + rewrite binint_pos_sub_succ_succ.
     unfold loopexp_pos.
     rewrite 2 pos_peano_ind_beta_pos_succ.
     change ((loopexp_pos p^ b @ p^) @ (loopexp_pos p a @ p)
-      = loopexp p (int_pos_sub a b)).
+      = loopexp p (binint_pos_sub a b)).
     rewrite (loopexp_pos_concat p).
     rewrite concat_pp_p, (concat_p_pp p^ p).
     rewrite concat_Vp, concat_1p.
     apply aH.
 Qed.
 
-Lemma loopexp_int_pos_sub_r {A : Type} {x : A} (p : x = x) (a b : Pos)
-  : loopexp p (int_pos_sub a b) = loopexp_pos p a @ loopexp_pos p^ b.
+Lemma loopexp_binint_pos_sub_r {A : Type} {x : A} (p : x = x) (a b : Pos)
+  : loopexp p (binint_pos_sub a b) = loopexp_pos p a @ loopexp_pos p^ b.
 Proof.
   symmetry.
   revert a b.
   induction a as [|a aH] using pos_peano_ind;
   induction b as [|b bH] using pos_peano_ind.
   + apply concat_pV.
-  + cbn; rewrite int_pos_sub_succ_r.
+  + cbn; rewrite binint_pos_sub_succ_r.
     unfold loopexp_pos.
     rewrite pos_peano_ind_beta_pos_succ.
     change (p @ (loopexp_pos p^ b @ p^) = loopexp p (neg b)).
     rewrite loopexp_pos_concat.
     by rewrite concat_p_pp, concat_pV, concat_1p.
-  + rewrite int_pos_sub_succ_l; cbn.
+  + rewrite binint_pos_sub_succ_l; cbn.
     unfold loopexp_pos.
     rewrite pos_peano_ind_beta_pos_succ.
     change ((loopexp_pos p a @ p) @ p^ = loopexp_pos p a).
     by rewrite concat_pp_p, concat_pV, concat_p1.
-  + rewrite int_pos_sub_succ_succ.
+  + rewrite binint_pos_sub_succ_succ.
     unfold loopexp_pos.
     rewrite 2 pos_peano_ind_beta_pos_succ.
     change ((loopexp_pos p a @ p) @ (loopexp_pos p^ b @ p^)
-      = loopexp p (int_pos_sub a b)).
+      = loopexp p (binint_pos_sub a b)).
     rewrite (loopexp_pos_concat p^).
     rewrite concat_pp_p, (concat_p_pp p p^).
     rewrite concat_pV, concat_1p.
@@ -168,28 +168,28 @@ Proof.
   try apply loopexp_pos_add; cbn.
   1,6: symmetry; apply concat_p1.
   2,3: symmetry; apply concat_1p.
-  1: apply loopexp_int_pos_sub_l.
-  apply loopexp_int_pos_sub_r.
+  1: apply loopexp_binint_pos_sub_l.
+  apply loopexp_binint_pos_sub_r.
 Qed.
 
 (** Under univalence, exponentiation of loops corresponds to iteration of autoequivalences. *)
 
 Definition equiv_path_loopexp
-           {A : Type} (p : A = A) (z : Int) (a : A)
-  : equiv_path A A (loopexp p z) a = int_iter (equiv_path A A p) z a.
+           {A : Type} (p : A = A) (z : BinInt) (a : A)
+  : equiv_path A A (loopexp p z) a = binint_iter (equiv_path A A p) z a.
 Proof.
   destruct z as [n| |n]; trivial.
   all: induction n as [|n IH]
     using pos_peano_ind; try reflexivity; cbn in *.
   all: unfold loopexp_pos; rewrite pos_peano_ind_beta_pos_succ.
-  all: unfold pos_iter; rewrite pos_peano_ind_beta_pos_succ.
+  all: unfold pos_iter; rewrite pos_peano_rec_beta_pos_succ.
   all: refine (transport_pp _ _ _ _ @ _); cbn; apply ap, IH.
 Defined.
 
 Definition loopexp_path_universe `{Univalence}
-           {A : Type} (f : A <~> A) (z : Int) (a : A)
+           {A : Type} (f : A <~> A) (z : BinInt) (a : A)
   : transport idmap (loopexp (path_universe f) z) a
-  = int_iter f z a.
+  = binint_iter f z a.
 Proof.
   revert f. equiv_intro (equiv_path A A) p.
   refine (_ @ equiv_path_loopexp p z a).
diff --git a/theories/Spaces/BinInt/Spec.v b/theories/Spaces/BinInt/Spec.v
new file mode 100644
index 00000000000..aadac1138be
--- /dev/null
+++ b/theories/Spaces/BinInt/Spec.v
@@ -0,0 +1,458 @@
+Require Import Basics.
+Require Import Spaces.Pos.
+Require Import Spaces.BinInt.Core.
+
+Local Set Universe Minimization ToSet.
+
+Local Open Scope binint_scope.
+
+(** ** Addition is commutative *)
+
+Lemma binint_add_comm n m : n + m = m + n.
+Proof.
+  destruct n, m; trivial. all: cbn.
+  all: apply ap, pos_add_comm.
+Defined.
+
+(** ** Zero is the additive identity. *)
+
+Definition binint_add_0_l n : 0 + n = n
+  := 1.
+
+Lemma binint_add_0_r n : n + 0 = n.
+Proof.
+  by destruct n.
+Defined.
+
+(** ** Multiplication by zero is zero *)
+
+Definition binint_mul_0_l n : 0 * n = 0
+  := 1.
+
+Lemma binint_mul_0_r n : n * 0 = 0.
+Proof.
+  by destruct n.
+Defined.
+
+(** ** One is the multiplicative identity *)
+
+Lemma binint_mul_1_l n : 1 * n = n.
+Proof.
+  by destruct n.
+Defined.
+
+Lemma binint_mul_1_r n : n * 1 = n.
+Proof.
+  destruct n; trivial; cbn; apply ap, pos_mul_1_r.
+Defined.
+
+(** ** Inverse laws *)
+
+Lemma binint_pos_sub_diag n : binint_pos_sub n n = 0.
+Proof.
+  induction n; trivial; cbn.
+  all: exact (ap binint_double IHn).
+Defined.
+
+Lemma binint_add_negation_l n : (-n) + n = 0.
+Proof.
+  destruct n; trivial; cbn; apply binint_pos_sub_diag.
+Defined.
+
+Lemma binint_add_negation_r n : n + (-n) = 0.
+Proof.
+  destruct n; trivial; cbn; apply binint_pos_sub_diag.
+Defined.
+
+(** ** Permutation of neg and pos_succ *)
+Lemma binint_neg_pos_succ p : neg (pos_succ p) = binint_pred (neg p).
+Proof.
+  by destruct p.
+Defined.
+
+(** ** Permutation of pos and pos_succ *)
+Lemma binint_pos_pos_succ p : pos (pos_succ p) = binint_succ (pos p).
+Proof.
+  by destruct p.
+Defined.
+
+(** ** Negation of a doubled positive integer *)
+Lemma binint_negation_double a : - (binint_double a) = binint_double (- a).
+Proof.
+  by destruct a.
+Defined.
+
+(** Negation of the predecessor of a doubled positive integer. *)
+Lemma binint_negation_pred_double a
+  : - (binint_pred_double a) = binint_succ_double (- a).
+Proof.
+  by destruct a.
+Defined.
+
+(** Negation of the doubling of the sucessor of an positive. *)
+Lemma binint_negation_succ_double a
+  : - (binint_succ_double a) = binint_pred_double (- a).
+Proof.
+  by destruct a.
+Defined.
+
+(** Negation of subtraction of positive integers *)
+Lemma binint_pos_sub_negation a b
+  : - (binint_pos_sub a b) = binint_pos_sub b a.
+Proof.
+  revert a b.
+  induction a as [|a ah|a ah];
+  destruct b;
+  cbn; trivial.
+  all: rewrite ?binint_negation_double,
+    ?binint_negation_succ_double,
+    ?binint_negation_pred_double.
+  all: apply ap, ah.
+Defined.
+
+(** ** binint_succ is a retract of binint_pred *)
+Definition binint_succ_pred : binint_succ o binint_pred == idmap.
+Proof.
+  intros [n | | n]; [|trivial|].
+  all: destruct n; trivial.
+  1,2: cbn; apply ap.
+  1: apply pos_pred_double_succ.
+  rewrite pos_add_1_r.
+  apply pos_succ_pred_double.
+Defined.
+
+(** ** binint_pred is a retract of binint_succ *)
+Definition binint_pred_succ : binint_pred o binint_succ == idmap.
+Proof.
+  intros [n | | n]; [|trivial|].
+  all: destruct n; trivial.
+  1,2: cbn; apply ap.
+  1: rewrite pos_add_1_r.
+  1: apply pos_succ_pred_double.
+  apply pos_pred_double_succ.
+Defined.
+
+(* ** The successor autoequivalence. *)
+Global Instance isequiv_binint_succ : IsEquiv binint_succ | 0
+  := isequiv_adjointify binint_succ _ binint_succ_pred binint_pred_succ.
+
+Definition equiv_binint_succ : BinInt <~> BinInt
+  := Build_Equiv _ _ _ isequiv_binint_succ.
+
+(** ** Negation distributes over addition *)
+Lemma binint_negation_add_distr n m : - (n + m) = - n + - m.
+Proof.
+ destruct n, m; simpl; trivial using binint_pos_sub_negation.
+Defined.
+
+(** ** Negation is injective *)
+Lemma binint_negation_inj n m : -n = -m -> n = m.
+Proof.
+  destruct n, m; simpl; intro H.
+  1: apply pos_inj in H.
+  2: apply pos_neq_zero in H.
+  3: apply pos_neq_neg in H.
+  4: apply  zero_neq_pos in H.
+  6: apply  zero_neq_neg in H.
+  7: apply  neg_neq_pos in H.
+  8: apply  neg_neq_zero in H.
+  9: apply  neg_inj in H.
+  all: by destruct H.
+Defined.
+
+(** ** Subtracting 1 from a sucessor gives the positive integer. *)
+Lemma binint_pos_sub_succ_l a
+  : binint_pos_sub (pos_succ a) 1%pos = pos a.
+Proof.
+  destruct a; trivial.
+  cbn; apply ap, pos_pred_double_succ.
+Defined.
+
+(** ** Subtracting a sucessor from 1 gives minus the integer. *)
+Lemma binint_pos_sub_succ_r a
+  : binint_pos_sub 1%pos (pos_succ a) = neg a.
+Proof.
+  destruct a; trivial.
+  cbn; apply ap, pos_pred_double_succ.
+Defined.
+
+(** ** Interaction of doubling functions and subtraction *)
+
+Lemma binint_succ_double_binint_pos_sub a b
+  : binint_succ_double (binint_pos_sub a (pos_succ b))
+    = binint_pred_double (binint_pos_sub a b).
+Proof.
+  revert a b.
+  induction a; induction b; trivial.
+  + cbn; apply ap.
+    by rewrite pos_pred_double_succ.
+  + destruct a; trivial.
+  + cbn; destruct (binint_pos_sub a b); trivial.
+  + cbn.
+    rewrite <- IHa.
+    destruct (binint_pos_sub a (pos_succ b)); trivial.
+  + destruct a; trivial.
+  + cbn; destruct (binint_pos_sub a b); trivial.
+  + cbn.
+    rewrite IHa.
+    cbn; destruct (binint_pos_sub a b); trivial.
+Defined.
+
+Lemma binint_pred_double_binint_pos_sub a b 
+  : binint_pred_double (binint_pos_sub (pos_succ a) b)
+    = binint_succ_double (binint_pos_sub a b).
+Proof.
+  revert a b.
+  induction a; induction b; trivial.
+  + by destruct b.
+  + by destruct b.
+  + cbn; by destruct (binint_pos_sub a b).
+  + cbn; by destruct (binint_pos_sub a b).
+  + cbn; apply ap.
+    by rewrite pos_pred_double_succ.
+  + cbn.
+    rewrite <- IHa.
+    by destruct (binint_pos_sub (pos_succ a) b).
+  + cbn.
+    rewrite IHa.
+    by destruct (binint_pos_sub a b).
+Defined.
+
+(** ** Subtractions cancel sucessors. *)
+Lemma binint_pos_sub_succ_succ a b
+  : binint_pos_sub (pos_succ a) (pos_succ b) = binint_pos_sub a b.
+Proof.
+  rewrite <- 2 pos_add_1_r.
+  revert a b.
+  induction a; induction b; trivial.
+  1: destruct b; trivial.
+  { destruct b; trivial.
+    cbn; apply ap.
+    by rewrite pos_pred_double_succ. }
+  1: destruct a; trivial.
+  1: apply binint_succ_double_binint_pos_sub.
+  { destruct a; trivial.
+    cbn; apply ap, ap, pos_pred_double_succ. }
+  1: apply binint_pred_double_binint_pos_sub.
+  cbn; apply ap.
+  rewrite <- 2 pos_add_1_r.
+  apply IHa.
+Defined.
+
+(** ** Predecessor of a subtraction is the subtraction of a sucessor. *)
+Lemma binint_pred_pos_sub_r a b
+  : binint_pred (binint_pos_sub a b) = binint_pos_sub a (pos_succ b).
+Proof.
+  revert a.
+  induction b as [|b bH] using pos_peano_ind.
+  1: destruct a; trivial; destruct a; trivial.
+  intro a.
+  revert b bH.
+  induction a as [|a aH] using pos_peano_ind.
+  { intros b bH.
+    rewrite <- bH.
+    destruct b; trivial.
+    cbn; apply ap.
+    rewrite 2 pos_add_1_r.
+    rewrite pos_succ_pred_double.
+    rewrite pos_pred_double_succ.
+    trivial. }
+  intros b bH.
+  rewrite 2 binint_pos_sub_succ_succ.
+  apply bH.
+Defined.
+
+(** ** Negation of the predecessor is an involution. *)
+Lemma binint_negation_pred_negation_red x
+  : - binint_pred (- binint_pred x) = x.
+Proof.
+  destruct x as [x| |x]; trivial;
+  destruct x; trivial; cbn; apply ap.
+  1: apply pos_pred_double_succ.
+  rewrite pos_add_1_r.
+  apply pos_succ_pred_double.
+Defined.
+
+(** ** Predecessor of a sum is the sum with a predecessor *)
+Lemma binint_pred_add_r a b
+  : binint_pred (a + b) = a + binint_pred b.
+Proof.
+  revert a b.
+  intros [a| |a] [b| |b]; trivial.
+  + cbn; apply ap.
+    by rewrite pos_add_assoc.
+  + revert a.
+    induction b as [|b bH] using pos_peano_ind.
+    - intro a; exact (binint_pred_succ (neg a)).
+    - intro a.
+      rewrite <- pos_add_1_r.
+      rewrite (binint_pred_succ (pos b)).
+      rewrite binint_add_comm.
+      cbn.
+      rewrite pos_add_1_r.
+      rewrite <- binint_pos_sub_negation.
+      rewrite <- binint_pred_pos_sub_r.
+      apply binint_negation_inj.
+      rewrite binint_pos_sub_negation.
+      apply binint_negation_pred_negation_red.
+  + cbn.
+    rewrite pos_add_1_r.
+    apply binint_pred_pos_sub_r.
+  + revert a.
+    induction b as [|b bH] using pos_peano_ind.
+    - intro a; exact (binint_pred_succ (pos a)).
+    - intro a.
+      rewrite <- pos_add_1_r.
+      rewrite (binint_pred_succ (pos b)).
+      cbn; rewrite pos_add_assoc.
+      change (binint_pred (binint_succ (pos (a + b)%pos)) = pos a + pos b).
+      apply binint_pred_succ.
+Defined.
+
+(** ** Subtraction from a sum is the sum of a subtraction *)
+Lemma binint_pos_sub_add (a b c : Pos)
+  : binint_pos_sub (a + b)%pos c = pos a + binint_pos_sub b c.
+Proof.
+  revert c b a.
+  induction c as [|c ch] using pos_peano_ind.
+  { intros b a.
+    change (binint_pred (pos a + pos b) = pos a + (binint_pred (pos b))).
+    apply binint_pred_add_r. }
+  intros b a.
+  rewrite <- binint_pred_pos_sub_r.
+  rewrite ch.
+  rewrite <- binint_pred_pos_sub_r.
+  apply binint_pred_add_r.
+Defined.
+
+(** An auxillary lemma used to prove associativity. *)
+Lemma binint_add_assoc_pos p n m : pos p + (n + m) = pos p + n + m.
+Proof.
+  destruct n as [n| |n], m as [m| |m]; trivial.
+  - cbn; apply binint_negation_inj.
+    rewrite !binint_negation_add_distr, !binint_pos_sub_negation.
+    rewrite binint_add_comm, pos_add_comm.
+    apply binint_pos_sub_add.
+  - symmetry.
+    apply binint_add_0_r.
+  - by rewrite <- binint_pos_sub_add, binint_add_comm,
+      <- binint_pos_sub_add, pos_add_comm.
+  - symmetry.
+    apply binint_pos_sub_add.
+  - cbn; apply ap, pos_add_assoc.
+Defined.
+
+(** ** Associativity of addition *)
+Lemma binint_add_assoc n m p : n + (m + p) = n + m + p.
+Proof.
+  destruct n.
+  - apply binint_negation_inj.
+    rewrite !binint_negation_add_distr.
+    apply binint_add_assoc_pos.
+  - trivial.
+  - apply binint_add_assoc_pos.
+Defined.
+
+(** ** Relationship between [int_succ], [int_pred] and addition. *)
+Lemma binint_add_succ_l a b : binint_succ a + b = binint_succ (a + b).
+Proof.
+  rewrite <- binint_add_assoc, (binint_add_comm 1 b).
+  apply binint_add_assoc.
+Defined.
+
+Lemma binint_add_succ_r a b : a + binint_succ b = binint_succ (a + b).
+Proof.
+  apply binint_add_assoc.
+Defined.
+
+Lemma binint_add_pred_l a b : binint_pred a + b = binint_pred (a + b).
+Proof.
+  rewrite <- binint_add_assoc, (binint_add_comm (-1) b).
+  apply binint_add_assoc.
+Defined.
+
+Lemma binint_add_pred_r a b : a + binint_pred b = binint_pred (a + b).
+Proof.
+  apply binint_add_assoc.
+Defined.
+
+(** ** Commutativity of multiplication *)
+Lemma binint_mul_comm n m : n * m = m * n.
+Proof.
+  destruct n, m; cbn; try reflexivity;
+  apply ap; apply pos_mul_comm.
+Defined.
+
+(** Distributivity of multiplication over addition *)
+
+Lemma binint_pos_sub_mul_pos n m p
+  : binint_pos_sub n m * pos p = binint_pos_sub (n * p)%pos (m * p)%pos.
+Proof.
+  rewrite binint_mul_comm.
+  rewrite 2 (pos_mul_comm _ p).
+  induction p.
+  { rewrite 2 pos_mul_1_l.
+    apply binint_mul_1_l. }
+  { cbn.
+    rewrite <- IHp.
+    set (binint_pos_sub n m) as k.
+    by destruct k. }
+  cbn.
+  rewrite binint_pos_sub_add.
+  rewrite <- (binint_pos_sub_negation _ (x0 _)).
+  rewrite binint_pos_sub_add.
+  rewrite binint_negation_add_distr.
+  rewrite binint_pos_sub_negation.
+  rewrite binint_add_assoc.
+  cbn.
+  rewrite <- IHp.
+  set (binint_pos_sub n m) as k.
+  by destruct k.
+Defined.
+
+Lemma binint_pos_sub_mul_neg n m p
+  : binint_pos_sub m n  * neg p = binint_pos_sub (n * p)%pos (m * p)%pos.
+Proof.
+  rewrite binint_mul_comm.
+  rewrite 2 (pos_mul_comm _ p).
+  induction p.
+  { rewrite 2 pos_mul_1_l.
+    rewrite <- binint_pos_sub_negation.
+    by destruct (binint_pos_sub n m). }
+  { cbn.
+    rewrite <- IHp.
+    rewrite <- binint_pos_sub_negation.
+    set (binint_pos_sub n m) as k.
+    by destruct k. }
+  cbn.
+  rewrite binint_pos_sub_add.
+  rewrite <- (binint_pos_sub_negation _ (x0 _)).
+  rewrite binint_pos_sub_add.
+  rewrite binint_negation_add_distr.
+  rewrite binint_pos_sub_negation.
+  rewrite binint_add_assoc.
+  cbn.
+  rewrite <- IHp.
+  rewrite <- (binint_pos_sub_negation m).
+  set (binint_pos_sub m n) as k.
+  by destruct k.
+Defined.
+
+Lemma binint_mul_add_distr_r n m p : (n + m) * p = n * p + m * p.
+Proof.
+  induction p; destruct n, m; cbn; trivial; try f_ap;
+  try apply pos_mul_add_distr_r;
+  try apply binint_pos_sub_mul_neg;
+  try apply binint_pos_sub_mul_pos;
+  apply binint_mul_0_r.
+Defined.
+
+Lemma binint_mul_add_distr_l n m p : n * (m + p) = n * m + n * p.
+Proof.
+  rewrite 3 (binint_mul_comm n); apply binint_mul_add_distr_r.
+Defined.
+
+Lemma binint_mul_assoc n m p : n * (m * p) = n * m * p.
+Proof.
+  destruct n, m, p; cbn; trivial; f_ap; apply pos_mul_assoc.
+Defined.
diff --git a/theories/Spaces/Card.v b/theories/Spaces/Card.v
index 7fadce8b398..f9441148e88 100644
--- a/theories/Spaces/Card.v
+++ b/theories/Spaces/Card.v
@@ -86,7 +86,7 @@ Section contents.
   Instance leftabsorb_card : LeftAbsorb mult_card zero_card.
   Proof. reduce. apply prod_empty_l. Defined.
 
-  Global Instance issemiring_card : IsSemiRing Card.
+  Global Instance issemiring_card : IsSemiCRing Card.
   Proof.
     repeat split; try apply _.
     - repeat intro. simpl_ops.
diff --git a/theories/Spaces/Circle.v b/theories/Spaces/Circle.v
index 160fa46175a..ba4bf1f75ea 100644
--- a/theories/Spaces/Circle.v
+++ b/theories/Spaces/Circle.v
@@ -2,10 +2,9 @@
 Require Import Basics Types.
 Require Import Pointed.Core Pointed.Loops Pointed.pEquiv.
 Require Import HSet.
-Require Import Spaces.Pos Spaces.Int.
+Require Import Spaces.Int.
 Require Import Colimits.Coeq.
 Require Import Truncations.Core Truncations.Connectedness.
-Require Import Cubical.DPath.
 
 (** * Theorems about the [Circle]. *)
 
@@ -126,52 +125,26 @@ Section EncodeDecode.
     refine (transport_arrow _ _ _ @ _).
     refine (transport_paths_r loop _ @ _).
     rewrite transport_Circle_code_loopV.
-    destruct z as [n| |n].
-    2: apply concat_Vp.
-    { rewrite <- int_neg_pos_succ.
-      unfold loopexp, loopexp_pos.
-      rewrite pos_peano_ind_beta_pos_succ.
-      apply concat_pV_p. }
-    induction n as [|n nH] using pos_peano_ind.
-    1: apply concat_1p.
-    rewrite <- pos_add_1_r.
-    change (pos (n + 1)%pos)
-      with (int_succ (pos n)).
-    rewrite int_pred_succ.
-    cbn; rewrite pos_add_1_r.
-    unfold loopexp_pos.
-    rewrite pos_peano_ind_beta_pos_succ.
-    reflexivity.
+    rewrite loopexp_pred_r.
+    apply concat_pV_p.
   Defined.
 
   (** The non-trivial part of the proof that decode and encode are equivalences is showing that decoding followed by encoding is the identity on the fibers over [base]. *)
-  Definition Circle_encode_loopexp (z:Int)
+  Definition Circle_encode_loopexp (z : Int)
     : Circle_encode base (loopexp loop z) = z.
   Proof.
-    destruct z as [n | | n]; unfold Circle_encode.
-    - induction n using pos_peano_ind; simpl in *.
-      + refine (moveR_transport_V _ loop _ _ _).
-        by symmetry; apply transport_Circle_code_loop.
-      + unfold loopexp_pos.
-        rewrite pos_peano_ind_beta_pos_succ.
-        rewrite transport_pp.
-        refine (moveR_transport_V _ loop _ _ _).
-        refine (_ @ (transport_Circle_code_loop _)^).
-        refine (IHn @ _^).
-        rewrite int_neg_pos_succ.
-        by rewrite int_succ_pred.
+    induction z as [|n | n].
     - reflexivity.
-    - induction n using pos_peano_ind; simpl in *.
-      + by apply transport_Circle_code_loop.
-      + unfold loopexp_pos.
-        rewrite pos_peano_ind_beta_pos_succ.
-        rewrite transport_pp.
-        refine (moveR_transport_p _ loop _ _ _).
-        refine (_ @ (transport_Circle_code_loopV _)^).
-        refine (IHn @ _^).
-        rewrite <- pos_add_1_r.
-        change (int_pred (int_succ (pos n)) = pos n).
-        apply int_pred_succ.
+    - rewrite loopexp_succ_r.
+      unfold Circle_encode in IHz |- *.
+      rewrite transport_pp.
+      rewrite IHz.
+      apply transport_Circle_code_loop.
+    - rewrite loopexp_pred_r.
+      unfold Circle_encode in IHz |- *.
+      rewrite transport_pp.
+      rewrite IHz.
+      apply transport_Circle_code_loopV.
   Defined.
 
   (** Now we put it together. *)
@@ -236,18 +209,6 @@ Proof.
   apply Circle_rec_beta_loop.
 Defined.
 
-(** An alternative induction principle for Circle that produces a DPath. *)
-Definition Circle_ind_dp (P : Circle -> Type) (b : P base)
-  (bl : DPath P loop b b) (x : Circle) : P x
-  := Circle_ind P b (dp_path_transport^-1 bl) x.
-
-Definition Circle_ind_dp_beta_loop (P : Circle -> Type) (b : P base)
-  (bl : DPath P loop b b) : dp_apD (Circle_ind_dp P b bl) loop = bl.
-Proof.
-  apply dp_apD_path_transport.
-  exact (Circle_ind_beta_loop _ _ _).
-Defined.
-
 (** The universal property of the circle (Lemma 6.2.9 in the Book).  We could deduce this from [isequiv_Coeq_rec], but it's nice to see a direct proof too. *)
 Definition Circle_rec_uncurried (P : Type)
   : {b : P & b = b} -> (Circle -> P)
diff --git a/theories/Spaces/Finite/Fin.v b/theories/Spaces/Finite/Fin.v
index 8db2f914a3c..afff1f75d04 100644
--- a/theories/Spaces/Finite/Fin.v
+++ b/theories/Spaces/Finite/Fin.v
@@ -267,7 +267,7 @@ Proof.
   assert (p' := (moveL_equiv_V _ _ p)^).
   exists y.
   destruct y as [y|[]].
-  + simple refine (equiv_unfunctor_sum_l@{Set Set Set Set Set Set Set Set Set Set}
+  + simple refine (equiv_unfunctor_sum_l@{Set Set Set Set Set Set}
               (fin_transpose_last_with m (inl y) oE e)
               _ _ ; _).
     { intros a. ev_equiv.
@@ -286,7 +286,7 @@ Proof.
     * rewrite unfunctor_sum_l_beta.
       apply fin_transpose_last_with_invol.
     * refine (fin_transpose_last_with_last _ _ @ p^).
-  + simple refine (equiv_unfunctor_sum_l@{Set Set Set Set Set Set Set Set Set Set} e _ _ ; _).
+  + simple refine (equiv_unfunctor_sum_l@{Set Set Set Set Set Set} e _ _ ; _).
     { intros a.
       destruct (is_inl_or_is_inr (e (inl a))) as [l|r].
       - exact l.
@@ -423,7 +423,8 @@ Fixpoint fin_nat {n : nat} (m : nat) : Fin n.+1
 
 (** The 1-dimensional version of Sperner's lemma says that given any finite sequence of decidable hProps, where the sequence starts with true and ends with false, we can find a point in the sequence where the sequence changes from true to false. This is like a discrete intermediate value theorem. *)
 Fixpoint sperners_lemma_1d {n} :
-  forall (f : Fin (n.+2) -> DHProp)
+  forall (f : Fin (n.+2) -> Type)
+         {dprop : forall i, Decidable (f i)}
          (left_true : f fin_zero)
          (right_false : ~ f fin_last),
     {k : Fin n.+1 & f (fin_incl k) /\ ~ f (fsucc k)}.
@@ -433,7 +434,7 @@ Proof.
   - exists fin_zero. split; assumption.
   - destruct (dec (f (fin_incl fin_last))) as [prev_true|prev_false].
     + exists fin_last. split; assumption.
-    + destruct (sperners_lemma_1d _ (f o fin_incl) left_true prev_false) as [k' [fleft fright]].
+    + destruct (sperners_lemma_1d _ (f o fin_incl) _ left_true prev_false) as [k' [fleft fright]].
       exists (fin_incl k').
       split; assumption.
 Defined.
diff --git a/theories/Spaces/Finite/FinInduction.v b/theories/Spaces/Finite/FinInduction.v
index ab3fefe470a..6cea070d52a 100644
--- a/theories/Spaces/Finite/FinInduction.v
+++ b/theories/Spaces/Finite/FinInduction.v
@@ -32,8 +32,8 @@ Proof.
   induction (path_fin_to_finnat_fin_zero n)^.
   intro p.
   destruct (hset_path2 1 p).
-  cbn.
-  by destruct (hset_path2 1 (path_zero_finnat n leq_1_Sn)).
+  lhs nrapply transport_1.
+  nrapply compute_finnat_ind_zero.
 Defined.
 
 Lemma compute_fin_ind_fsucc (P : forall n : nat, Fin n -> Type)
diff --git a/theories/Spaces/Finite/FinNat.v b/theories/Spaces/Finite/FinNat.v
index 6314ae40233..9d7132b5312 100644
--- a/theories/Spaces/Finite/FinNat.v
+++ b/theories/Spaces/Finite/FinNat.v
@@ -10,7 +10,7 @@ Local Open Scope nat_scope.
 Definition FinNat (n : nat) : Type0 := {x : nat | x < n}.
 
 Definition zero_finnat (n : nat) : FinNat n.+1
-  := (0; leq_1_Sn).
+  := (0; _ : 0 < n.+1).
 
 Lemma path_zero_finnat (n : nat) (h : 0 < n.+1) : zero_finnat n = (0; h).
 Proof.
@@ -18,7 +18,7 @@ Proof.
 Defined.
 
 Definition succ_finnat {n : nat} (u : FinNat n) : FinNat n.+1
-  := (u.1.+1; leq_S_n' u.1.+1 n u.2).
+  := (u.1.+1; leq_succ u.2).
 
 Lemma path_succ_finnat {n : nat} (u : FinNat n) (h : u.1.+1 < n.+1)
   : succ_finnat u = (u.1.+1; h).
@@ -36,7 +36,7 @@ Proof.
 Defined.
 
 Definition incl_finnat {n : nat} (u : FinNat n) : FinNat n.+1
-  := (u.1; leq_trans u.2 (leq_S n n (leq_n n))).
+  := (u.1; leq_trans u.2 (leq_succ_r (leq_refl n))).
 
 Lemma path_incl_finnat (n : nat) (u : FinNat n) (h : u.1 < n.+1)
   : incl_finnat u = (u.1; h).
@@ -51,11 +51,11 @@ Definition finnat_ind (P : forall n : nat, FinNat n -> Type)
   : P n u.
 Proof.
   induction n as [| n IHn].
-  - elim (not_lt_n_0 u.1 u.2).
+  - elim (not_lt_zero_r u.1 u.2).
   - destruct u as [x h].
     destruct x as [| x].
     + exact (transport (P n.+1) (path_zero_finnat _ h) (z _)).
-    + refine (transport (P n.+1) (path_succ_finnat (x; leq_S_n _ _ h) _) _).
+    + refine (transport (P n.+1) (path_succ_finnat (x; leq_pred' h) _) _).
       apply s. apply IHn.
 Defined.
 
@@ -65,7 +65,10 @@ Lemma compute_finnat_ind_zero (P : forall n : nat, FinNat n -> Type)
   (n : nat)
   : finnat_ind P z s (zero_finnat n) = z n.
 Proof.
-  cbn. by induction (hset_path2 1 (path_zero_finnat n leq_1_Sn)).
+  unshelve lhs snrapply transport2.
+  - reflexivity.
+  - rapply hset_path2.
+  - reflexivity.
 Defined.
 
 Lemma compute_finnat_ind_succ (P : forall n : nat, FinNat n -> Type)
@@ -78,11 +81,10 @@ Proof.
   refine
     (_ @ transport
           (fun p => transport _ p (s n u _) = s n u (finnat_ind P z s u))
-          (hset_path2 1 (path_succ_finnat u (leq_S_n' _ _ u.2))) 1).
+          (hset_path2 1 (path_succ_finnat u (leq_succ u.2))) 1).
   destruct u as [u1 u2].
-  assert (u2 = leq_S_n u1.+1 n (leq_S_n' u1.+1 n u2)) as p.
-  - apply path_ishprop.
-  - simpl. by induction p.
+  assert (u2 = leq_pred' (leq_succ u2)) as p by apply path_ishprop.
+  simpl; by induction p.
 Defined.
 
 Monomorphic Definition is_bounded_fin_to_nat {n} (k : Fin n)
@@ -93,7 +95,7 @@ Proof.
   - destruct k as [k | []].
     + apply (@leq_trans _ n _).
       * apply IHn.
-      * by apply leq_S.
+      * by apply leq_succ_r.
     + apply leq_refl.
 Defined.
 
@@ -102,11 +104,11 @@ Monomorphic Definition fin_to_finnat {n} (k : Fin n) : FinNat n
 
 Monomorphic Fixpoint finnat_to_fin {n : nat} : FinNat n -> Fin n
   := match n with
-     | 0 => fun u => Empty_rec (not_lt_n_0 _ u.2)
+     | 0 => fun u => Empty_rec (not_lt_zero_r _ u.2)
      | n.+1 => fun u =>
         match u with
         | (0; _) => fin_zero
-        | (x.+1; h) => fsucc (finnat_to_fin (x; leq_S_n _ _ h))
+        | (x.+1; h) => fsucc (finnat_to_fin (x; leq_pred' h))
         end
      end.
 
@@ -152,12 +154,12 @@ Lemma path_finnat_to_fin_incl {n : nat} (u : FinNat n)
   : finnat_to_fin (incl_finnat u) = fin_incl (finnat_to_fin u).
 Proof.
   induction n as [| n IHn].
-  - elim (not_lt_n_0 _ u.2).
+  - elim (not_lt_zero_r _ u.2).
   - destruct u as [x h].
     destruct x as [| x]; [reflexivity|].
-    refine ((ap _ (ap _ (path_succ_finnat (x; leq_S_n _ _ h) h)))^ @ _).
-    refine (_ @ ap fsucc (IHn (x; leq_S_n _ _ h))).
-    by induction (path_finnat_to_fin_succ (incl_finnat (x; leq_S_n _ _ h))).
+    refine ((ap _ (ap _ (path_succ_finnat (x; leq_pred' h) h)))^ @ _).
+    refine (_ @ ap fsucc (IHn (x; leq_pred' h))).
+    by induction (path_finnat_to_fin_succ (incl_finnat (x; leq_pred' h))).
 Defined.
 
 Lemma path_finnat_to_fin_last (n : nat)
@@ -172,13 +174,13 @@ Lemma path_finnat_to_fin_to_finnat {n : nat} (u : FinNat n)
   : fin_to_finnat (finnat_to_fin u) = u.
 Proof.
   induction n as [| n IHn].
-  - elim (not_lt_n_0 _ u.2).
+  - elim (not_lt_zero_r _ u.2).
   - destruct u as [x h].
     apply path_sigma_hprop.
     destruct x as [| x].
     + exact (ap pr1 (path_fin_to_finnat_fin_zero n)).
     + refine ((path_fin_to_finnat_fsucc _)..1 @ _).
-      exact (ap S (IHn (x; leq_S_n _ _ h))..1).
+      exact (ap S (IHn (x; leq_pred' h))..1).
 Defined.
 
 Lemma path_fin_to_finnat_to_fin {n : nat} (k : Fin n)
diff --git a/theories/Spaces/Finite/FinSeq.v b/theories/Spaces/Finite/FinSeq.v
index 330061197d3..a5841f68c84 100644
--- a/theories/Spaces/Finite/FinSeq.v
+++ b/theories/Spaces/Finite/FinSeq.v
@@ -27,9 +27,9 @@ Defined.
 
 (** Add an element in the end of a finite sequence, [fscons'] and [fscons]. *)
 
-Definition fscons' {A : Type} (n : nat) (a : A) (v : FinSeq (pred n) A)
+Definition fscons' {A : Type} (n : nat) (a : A) (v : FinSeq (nat_pred n) A)
   : FinSeq n A
-  := fun i =>  fin_rec (fun n => FinSeq (pred n) A -> A)
+  := fun i =>  fin_rec (fun n => FinSeq (nat_pred n) A -> A)
                        (fun _ _ => a) (fun n' i _ v => v i) i v.
 
 Definition fscons {A : Type} {n : nat} : A -> FinSeq n A -> FinSeq n.+1 A
@@ -40,16 +40,16 @@ Definition fscons {A : Type} {n : nat} : A -> FinSeq n A -> FinSeq n.+1 A
 
 Definition fshead' {A} (n : nat) : 0 < n -> FinSeq n A -> A
   := match n with
-     | 0 => fun N _ => Empty_rec (not_lt_n_0 _ N)
+     | 0 => fun N _ => Empty_rec (not_lt_zero_r _ N)
      | n'.+1 => fun _ v => v fin_zero
      end.
 
 Definition fshead {A} {n : nat} : FinSeq n.+1 A -> A := fshead' n.+1 _.
 
-Definition compute_fshead' {A} n (N : n > 0) (a : A) (v : FinSeq (pred n) A)
+Definition compute_fshead' {A} n (N : n > 0) (a : A) (v : FinSeq (nat_pred n) A)
   : fshead' n N (fscons' n a v) = a.
 Proof.
-  destruct n; [elim (not_lt_n_n _ N)|].
+  destruct n; [elim (lt_irrefl _ N)|].
   exact (apD10 (compute_fin_rec_fin_zero _ _ _ _) v).
 Defined.
 
@@ -61,7 +61,7 @@ Defined.
 
 (** If the sequence is non-empty, then remove the first element. *)
 
-Definition fstail' {A} (n : nat) : FinSeq n A -> FinSeq (pred n) A
+Definition fstail' {A} (n : nat) : FinSeq n A -> FinSeq (nat_pred n) A
   := match n with
      | 0 => fun _ => Empty_rec
      | n'.+1 => fun v i => v (fsucc i)
@@ -71,7 +71,7 @@ Definition fstail' {A} (n : nat) : FinSeq n A -> FinSeq (pred n) A
 
 Definition fstail {A} {n : nat} : FinSeq n.+1 A -> FinSeq n A := fstail' n.+1.
 
-Definition compute_fstail' {A} n (a : A) (v : FinSeq (pred n) A)
+Definition compute_fstail' {A} n (a : A) (v : FinSeq (nat_pred n) A)
   : fstail' n (fscons' n a v) == v.
 Proof.
   intro i.
@@ -109,7 +109,7 @@ Defined.
     a path between [fscons] finite sequences. They cooperate nicely with
     [path_expand_fscons'] and [path_expand_fscons]. *)
 
-Definition path_fscons' {A} n {a1 a2 : A} {v1 v2 : FinSeq (pred n) A}
+Definition path_fscons' {A} n {a1 a2 : A} {v1 v2 : FinSeq (nat_pred n) A}
   (p : a1 = a2) (q : forall i, v1 i = v2 i) (i : Fin n)
   : fscons' n a1 v1 i = fscons' n a2 v2 i.
 Proof.
@@ -120,7 +120,7 @@ Proof.
 Defined.
 
 Definition compute_path_fscons' {A} (n : nat)
-    (a : A) (v : FinSeq (pred n) A) (i : Fin n)
+    (a : A) (v : FinSeq (nat_pred n) A) (i : Fin n)
     : path_fscons' n (idpath a) (fun j => idpath (v j)) i = idpath.
 Proof.
   induction i using fin_ind; unfold path_fscons'.
@@ -153,7 +153,7 @@ Defined.
     [path_expand_fscons] with [path_fscons]. *)
 
 Lemma path_expand_fscons_fscons' {A : Type} (n : nat)
-  (N : n > 0) (a : A) (v : FinSeq (pred n) A) (i : Fin n)
+  (N : n > 0) (a : A) (v : FinSeq (nat_pred n) A) (i : Fin n)
   : path_expand_fscons' n i N (fscons' n a v) =
     path_fscons' n (compute_fshead' n N a v) (compute_fstail' n a v) i.
 Proof.
diff --git a/theories/Spaces/Finite/Finite.v b/theories/Spaces/Finite/Finite.v
index 387e9e7432c..648850a28e0 100644
--- a/theories/Spaces/Finite/Finite.v
+++ b/theories/Spaces/Finite/Finite.v
@@ -2,7 +2,7 @@
 Require Import Basics.
 Require Import Types.
 Require Import HSet.
-Require Import Spaces.Nat.Core.
+Require Import Spaces.Nat.Core Spaces.Nat.Factorial.
 Require Import HFiber.
 Require Import Factorization.
 Require Import Truncations.
@@ -300,7 +300,7 @@ Proof.
     refine (fcard_sum _ _ @ _).
     simpl.
     refine (_ @ nat_add_comm _ _).
-    refine (ap011 add _ _).
+    refine (ap011 nat_add _ _).
     + apply IH.
     + apply fcard_equiv', prod_unit_l.
   Defined.
@@ -333,20 +333,21 @@ Defined.
 #[local] Hint Extern 4 => progress (cbv beta iota) : typeclass_instances.
 
 Definition fcard_arrow `{Funext} X Y `{Finite X} `{Finite Y}
-: fcard (X -> Y) = nat_exp (fcard Y) (fcard X).
+: fcard (X -> Y) = nat_pow (fcard Y) (fcard X).
 Proof.
   assert (e := merely_equiv_fin X).
   strip_truncations.
   refine (fcard_equiv (functor_arrow e idmap)^-1 @ _).
-  refine (_ @ ap (fun x => nat_exp (fcard Y) x) (fcard_equiv e)).
+  refine (_ @ ap (fun x => nat_pow (fcard Y) x) (fcard_equiv e)).
   generalize (fcard X); intros n.
   induction n as [|n IH].
   - reflexivity.
   - refine (fcard_equiv (equiv_sum_ind (fun (_:Fin n.+1) => Y))^-1 @ _).
     refine (fcard_prod _ _ @ _).
-    apply (ap011 mul).
-    + assumption.
+    lhs nrapply nat_mul_comm.
+    apply (ap011 nat_mul).
     + refine (fcard_equiv (@Unit_ind (fun (_:Unit) => Y))^-1).
+    + assumption.
 Defined.
 
 (** [fcard] still computes, despite the funext: *)
@@ -487,7 +488,7 @@ Defined.
 
 (** The product of a finite constant family is the exponential by its cardinality. *)
 Definition finmult_const `{Funext} X `{Finite X} n
-: finmult (fun x:X => n) = nat_exp n (fcard X).
+: finmult (fun x:X => n) = nat_pow n (fcard X).
 Proof.
   refine (fcard_arrow X (Fin n)).
 Defined.
@@ -521,10 +522,10 @@ Definition detachable_finite_subset {X} `{Finite X}
 : forall x, Decidable (P x).
 Proof.
   intros x.
-  refine (decidable_equiv _ (hfiber_fibration x P)^-1 _).
-  (* The try clause below is only needed for Coq <= 8.11 *)
-  refine (detachable_image_finite pr1 x); try assumption.
-  - apply (mapinO_pr1 (Tr (-1))).  (** Why doesn't Coq find this? *)
+  nrefine (decidable_equiv' _ (hfiber_fibration x P)^-1%equiv _).
+  nrefine (detachable_image_finite pr1 x).
+  1,2: exact _.
+  apply (mapinO_pr1 (Tr (-1))).  (** Why doesn't Coq find this? *)
 Defined.
 
 (** ** Quotients *)
@@ -646,7 +647,7 @@ Proof.
   induction n as [|n IHn].
   1: exact _.
   intros m g ?.
-  assert (i : isinj g) by (apply isinj_embedding; exact _).
+  assert (i : IsInjective g) by (apply isinj_embedding; exact _).
   destruct m as [|m].
   { elim (g (inr tt)). }
   pose (h := (fin_transpose_last_with m (g (inr tt)))^-1 o g).
@@ -676,7 +677,7 @@ Proof.
     { unfold h; apply moveR_equiv_V; symmetry.
       apply fin_transpose_last_with_last. }
     rewrite q; exact tt. }
-  apply leq_S_n'.
+  apply leq_succ.
   exact (IHn m (unfunctor_sum_l h Ha)
              (mapinO_unfunctor_sum_l (Tr (-1)) h Ha Hb)).
 Qed.
@@ -750,7 +751,7 @@ Section Enumeration.
   Proof.
     destruct (finite_enumeration_stage (fcard X).+1) as [p|?].
     - assert (q := leq_inj_finite (er (fcard X).+1) p); simpl in q.
-      elim (not_lt_n_n _ q).
+      elim (lt_irrefl _ q).
     - assumption.
   Defined.
 
diff --git a/theories/Spaces/FreeInt.v b/theories/Spaces/FreeInt.v
new file mode 100644
index 00000000000..0e6e45233bd
--- /dev/null
+++ b/theories/Spaces/FreeInt.v
@@ -0,0 +1,71 @@
+Require Import Basics Types WildCat.Core Truncations.Core Spaces.Int
+  AbelianGroup AbHom Centralizer AbProjective Groups.FreeGroup AbGroups.Z.
+
+(** * The free group on one generator *)
+
+(** We can define the integers as the free group on one generator, which we denote [Z1] below. Results from Centralizer.v and Groups.FreeGroup let us show that [Z1] is abelian. *)
+
+(** We define [Z1] as the free group with a single generator. *)
+Definition Z1 := FreeGroup Unit.
+Definition Z1_gen : Z1 := freegroup_in tt. (* The generator *)
+
+(** The recursion principle of [Z1] and its computation rule. *)
+Definition Z1_rec {G : Group} (g : G) : Z1 $-> G
+  := FreeGroup_rec Unit G (unit_name g).
+
+Definition Z1_rec_beta {G : Group} (g : G) : Z1_rec g Z1_gen = g
+  := FreeGroup_rec_beta _ _ _.
+
+(** The free group [Z1] on one generator is isomorphic to the subgroup of [Z1] generated by the generator.  And such cyclic subgroups are known to be commutative, by [commutative_cyclic_subgroup]. *)
+Global Instance Z1_commutative `{Funext} : Commutative (@group_sgop Z1)
+  := commutative_iso_commutative iso_subgroup_incl_freegroupon.
+(* TODO: [Funext] is used in [isfreegroupon_freegroup], but there is a comment there saying that it can be removed.  If that is done, can remove it from many results in this file. A different proof of this result, directly using the construction of the free group, could probably also avoid [Funext]. *)
+
+Definition ab_Z1 `{Funext} : AbGroup
+  := Build_AbGroup Z1 _.
+
+(** The universal property of [ab_Z1]. *)
+Lemma equiv_Z1_hom@{u v | u < v} `{Funext} (A : AbGroup@{u})
+  : GroupIsomorphism (ab_hom@{u v} ab_Z1@{u v} A) A.
+Proof.
+  snrapply Build_GroupIsomorphism'.
+  - refine (_ oE (equiv_freegroup_rec@{u u u v} A Unit)^-1).
+    symmetry. refine (Build_Equiv _ _ (fun a => unit_name a) _).
+  - intros f g. cbn. reflexivity.
+Defined.
+
+Definition nat_to_Z1 : nat -> Z1
+  := fun n => grp_pow Z1_gen n.
+
+Definition Z1_mul_nat `{Funext} (n : nat) : ab_Z1 $-> ab_Z1
+  := Z1_rec (nat_to_Z1 n).
+
+Lemma Z1_mul_nat_beta {A : AbGroup} (a : A) (n : nat)
+  : Z1_rec a (nat_to_Z1 n) = ab_mul n a.
+Proof.
+  induction n as [|n H].
+  1: easy.
+  exact (grp_pow_natural _ _ _).
+Defined.
+
+(** [ab_Z1] is projective. *)
+Global Instance ab_Z1_projective `{Funext}
+  : IsAbProjective ab_Z1.
+Proof.
+  intros A B p f H1.
+  pose proof (a := @center _ (H1 (f Z1_gen))).
+  strip_truncations.
+  snrefine (tr (Z1_rec a.1; _)).
+  cbn beta. apply ap10.
+  apply ap. (* of the coercion [grp_homo_map] *)
+  apply path_homomorphism_from_free_group.
+  simpl.
+  intros [].
+  exact a.2.
+Defined.
+
+(** The map sending the generator to [1 : Int]. *)
+Definition Z1_to_Z `{Funext} : ab_Z1 $-> abgroup_Z
+  := Z1_rec (G:=abgroup_Z) 1%int.
+
+(** TODO:  Prove that [Z1_to_Z] is a group isomorphism. *)
diff --git a/theories/Spaces/Int.v b/theories/Spaces/Int.v
index 2e5c7a9dfee..730837842cf 100644
--- a/theories/Spaces/Int.v
+++ b/theories/Spaces/Int.v
@@ -1,4 +1,785 @@
-Require Export HoTT.Spaces.Int.Core.
-Require Export HoTT.Spaces.Int.Spec.
-Require Export HoTT.Spaces.Int.Equiv.
-Require Export HoTT.Spaces.Int.LoopExp.
\ No newline at end of file
+Require Import Basics.Overture Basics.Nat Basics.Tactics Basics.Decidable Basics.Equivalences Basics.PathGroupoids Types.Paths Types.Universe.
+Require Basics.Numerals.Decimal.
+Require Import Spaces.Nat.Core.
+
+Unset Elimination Schemes.
+Set Universe Minimization ToSet.
+
+Declare Scope int_scope.
+Delimit Scope int_scope with int.
+Local Open Scope int_scope.
+
+(** * The Integers *)
+
+(** ** Definition *)
+
+(** We define the integers as two copies of [nat] stuck together around a [zero]. *)
+Inductive Int : Type0 :=
+| negS : nat -> Int
+| zero : Int
+| posS : nat -> Int.
+
+(** We can convert a [nat] to an [Int] by mapping [0] to [zero] and [S n] to [posS n]. Various operations on [nat] are preserved by this function. See the section on conversion functions starting with [int_nat_succ]. *)
+Definition int_of_nat (n : nat) :=
+  match n with
+  | O => zero
+  | S n => posS n
+  end.
+
+(** We declare this conversion as a coercion so we can freely use [nat]s in statements about integers. *)
+Coercion int_of_nat : nat >-> Int.
+
+(** ** Number Notations *)
+
+(** Here we define some printing and parsing functions that convert the integers between numeral representations so that we can use notations such as [123] for [posS 122] and [-123] for [negS 122]. *)
+
+(** Printing *)
+Definition int_to_number_int (n : Int) : Numeral.int :=
+  match n with
+  | posS n => Numeral.IntDec (Decimal.Pos (Nat.to_uint (S n)))
+  | zero => Numeral.IntDec (Decimal.Pos (Nat.to_uint 0))
+  | negS n => Numeral.IntDec (Decimal.Neg (Nat.to_uint (S n)))
+  end.
+
+(** Parsing *)
+Definition int_of_number_int (d : Numeral.int) :=
+  match d with
+  | Numeral.IntDec (Decimal.Pos d) => int_of_nat (Nat.of_uint d)
+  | Numeral.IntDec (Decimal.Neg d) => negS (nat_pred (Nat.of_uint d))
+  | Numeral.IntHex (Hexadecimal.Pos u) => int_of_nat (Nat.of_hex_uint u)
+  | Numeral.IntHex (Hexadecimal.Neg u) => negS (nat_pred (Nat.of_hex_uint u))
+  end.
+
+Number Notation Int int_of_number_int int_to_number_int : int_scope.
+
+(** ** Successor, Predecessor and Negation *)
+
+(** These operations will be used in the induction principle we derive for [Int] so we need to define them early on. *)
+
+(** *** Successor and Predecessor *)
+
+Definition int_succ (n : Int) : Int :=
+  match n with
+  | posS n => posS (S n)
+  | 0 => 1
+  | -1 => 0
+  | negS (S n) => negS n
+  end.
+
+Notation "n .+1" := (int_succ n) : int_scope.
+
+Definition int_pred (n : Int) : Int :=
+  match n with
+  | posS (S n) => posS n
+  | 1 => 0 
+  | 0 => -1
+  | negS n => negS (S n)
+  end.
+
+Notation "n .-1" := (int_pred n) : int_scope.
+
+(** *** Negation *)
+
+Definition int_neg@{} (x : Int) : Int :=
+  match x with
+  | posS x => negS x
+  | zero => zero
+  | negS x => posS x
+  end.
+
+Notation "- x" := (int_neg x) : int_scope.
+
+(** ** Basic Properties *)
+
+(** *** Integer induction *)
+
+(** The induction principle for integers is similar to the induction principle for natural numbers. However we have two induction hypotheses going in either direction starting from 0. *)
+Definition Int_ind@{i} (P : Int -> Type@{i})
+  (H0 : P 0)
+  (HP : forall n : nat, P n -> P (int_succ n))
+  (HN : forall n : nat, P (- n) -> P (int_pred (-n)))
+  : forall x, P x.
+Proof.
+  intros[x | | x].
+  - induction x as [|x IHx].
+    + apply (HN 0%nat), H0.
+    + apply (HN x.+1%nat), IHx.
+  - exact H0.
+  - induction x as [|x IHx].
+    * apply (HP 0%nat), H0.
+    * apply (HP x.+1%nat), IHx.
+Defined.
+
+(** We record these so that they can be used with the [induction] tactic. *)
+Definition Int_rect := Int_ind.
+Definition Int_rec := Int_ind.
+
+(** *** Decidable Equality *)
+
+(** The integers have decidable equality. *)
+Global Instance decidable_paths_int@{} : DecidablePaths Int.
+Proof.
+  intros x y.
+  destruct x as [x | | x], y as [y |  | y].
+  2-4,6-8: right; intros; discriminate.
+  2: by left.
+  1,2: nrapply decidable_iff.
+  1,3: split.
+  1,3: nrapply ap.
+  1,2: intros H; by injection H.
+  1,2: exact _.
+Defined.
+
+(** By Hedberg's theorem, we have that the integers are a set. *)
+Global Instance ishset_int@{} : IsHSet Int := _.
+
+(** *** Pointedness *)
+
+(** We sometimes want to treat the integers as a pointed type with basepoint given by 0. *)
+Global Instance ispointed_int : IsPointed Int := 0.
+
+(** ** Operations *)
+
+(** *** Addition *)
+
+(** Addition for integers is defined by integer inductionn on the first argument. *)
+Definition int_add@{} (x y : Int) : Int.
+Proof.
+  induction x as [|x IHx|x IHx] in y |- *.
+  (** [0 + y = y] *)
+  - exact y.
+  (** [x.+1 + y = (x + y).+1] *)
+  - exact (int_succ (IHx y)).
+  (** [x.-1 + y = (x + y).-1] *)
+  - exact (int_pred (IHx y)).
+Defined.
+
+Infix "+" := int_add : int_scope.
+Infix "-" := (fun x y => x + -y) : int_scope.
+
+(** *** Multiplication *)
+
+(** Multiplication for integers is defined by integer induction on the first argument. *)
+Definition int_mul@{} (x y : Int) : Int.
+Proof.
+  induction x as [|x IHx|x IHx] in y |- *.
+  (** [0 * y = 0] *)
+  - exact 0.
+  (** [x.+1 * y = y + x * y] *)
+  - exact (y + IHx y).
+  (** [x.-1 * y = -y + x * y] *)
+  - exact (-y + IHx y).
+Defined.
+
+Infix "*" := int_mul : int_scope.
+
+(** ** Properties of Operations *)
+
+(** *** Negation *)
+
+(** Negation is involutive. *)
+Definition int_neg_neg@{} (x : Int) : - - x = x.  
+Proof.
+  by destruct x.
+Defined.
+
+(** Negation is an equivalence. *)
+Global Instance isequiv_int_neg@{} : IsEquiv int_neg.
+Proof.
+  snrapply (isequiv_adjointify int_neg int_neg).
+  1,2: nrapply int_neg_neg.
+Defined.
+
+(** Negation is injective. *)
+Definition isinj_int_neg@{} (x y : Int) : - x = - y -> x = y
+  := equiv_inj int_neg.
+
+(** The negation of a successor is the predecessor of the negation. *)
+Definition int_neg_succ (x : Int) : - x.+1 = (- x).-1.
+Proof.
+  by destruct x as [[] | | ].
+Defined.
+
+(** The negation of a predecessor is the successor of the negation. *)
+Definition int_neg_pred (x : Int) : - x.-1 = (- x).+1.
+Proof.
+  by destruct x as [ | | []].
+Defined.
+
+(** The successor of a predecessor is the identity. *)
+Definition int_pred_succ@{} (x : Int) : x.-1.+1 = x.
+Proof.
+  by destruct x as [ | | []].
+Defined. 
+
+(** The predecessor of a successor is the identity. *)
+Definition int_succ_pred@{} (x : Int) : x.+1.-1 = x.
+Proof.
+  by destruct x as [[] | | ].
+Defined.
+
+(** The successor is an equivalence on [Int] *)
+Global Instance isequiv_int_succ@{} : IsEquiv int_succ
+  := isequiv_adjointify int_succ int_pred int_pred_succ int_succ_pred.
+
+(** The predecessor is an equivalence on [Int] *)
+Global Instance isequiv_int_pred@{} : IsEquiv int_pred
+  := isequiv_inverse int_succ.
+
+(** *** Addition *)
+
+(** Integer addition with zero on the left is the identity by definition. *)
+Definition int_add_0_l@{} (x : Int) : 0 + x = x := 1.
+
+(** Integer addition with zero on the right is the identity. *)
+Definition int_add_0_r@{} (x : Int) : x + 0 = x.
+Proof.
+  induction x as [|[|x] IHx|[|x] IHx].
+  - reflexivity.
+  - reflexivity.
+  - change (?z.+1 + 0) with (z + 0).+1.
+    exact (ap _ IHx).
+  - reflexivity.
+  - change (?z.-1 + 0) with (z + 0).-1.
+    exact (ap _ IHx).
+Defined. 
+
+(** Adding a successor on the left is the successor of the sum. *)
+Definition int_add_succ_l@{} (x y : Int) : x.+1 + y = (x + y).+1.
+Proof.
+  induction x as [|[|x] IHx|[|x] IHx] in y |- *.
+  1-3: reflexivity.
+  all: symmetry; apply int_pred_succ.
+Defined.
+
+(** Adding a predecessor on the left is the predecessor of the sum. *)
+Definition int_add_pred_l@{} (x y : Int) : x.-1 + y = (x + y).-1.
+Proof.
+  induction x as [|[|x] IHx|[|x] IHx] in y |- *.
+  1,4,5: reflexivity.
+  all: symmetry; apply int_succ_pred.
+Defined.
+
+(** Adding a successor on the right is the successor of the sum. *)
+Definition int_add_succ_r@{} (x y : Int) : x + y.+1 = (x + y).+1.
+Proof.
+  induction x as [|x IHx|[] IHx] in y |- *.
+  - reflexivity.
+  - by rewrite 2 int_add_succ_l, IHx.
+  - cbn; by rewrite int_succ_pred, int_pred_succ.
+  - change ((- (n.+1%nat)).-1 + y.+1 = ((- (n.+1%nat)).-1 + y).+1).
+    rewrite int_add_pred_l.
+    rewrite IHx.
+    rewrite <- 2 int_add_succ_l.
+    rewrite <- int_add_pred_l.
+    by rewrite int_pred_succ, int_succ_pred.
+Defined.
+
+(** Adding a predecessor on the right is the predecessor of the sum. *)
+Definition int_add_pred_r (x y : Int) : x + y.-1 = (x + y).-1.
+Proof.
+  induction x as [|x IHx|[] IHx] in y |- *.
+  - reflexivity.
+  - rewrite 2 int_add_succ_l.
+    rewrite IHx.
+    by rewrite int_pred_succ, int_succ_pred.
+  - reflexivity.
+  - rewrite 2 int_add_pred_l.
+    by rewrite IHx.
+Defined.
+
+(** Integer addition is commutative. *)
+Definition int_add_comm@{} (x y : Int) : x + y = y + x.
+Proof.
+  induction y as [|y IHy|y IHy] in x |- *.
+  - apply int_add_0_r.
+  - rewrite int_add_succ_l.
+    rewrite <- IHy.
+    by rewrite int_add_succ_r.
+  - rewrite int_add_pred_r.
+    rewrite int_add_pred_l.
+    f_ap.
+Defined.
+
+(** Integer addition is associative. *)
+Definition int_add_assoc@{} (x y z : Int) : x + (y + z) = x + y + z.
+Proof.
+  induction x as [|x IHx|x IHx] in y, z |- *.
+  - reflexivity.
+  - by rewrite !int_add_succ_l, IHx.
+  - by rewrite !int_add_pred_l, IHx.
+Defined.
+
+(** Negation is a left inverse with respect to integer addition. *)
+Definition int_add_neg_l@{} (x : Int) : - x + x = 0.
+Proof.
+  induction x as [|x IHx|x IHx].
+  - reflexivity.
+  - by rewrite int_neg_succ, int_add_pred_l, int_add_succ_r, IHx.
+  - by rewrite int_neg_pred, int_add_succ_l, int_add_pred_r, IHx.
+Defined.
+
+(** Negation is a right inverse with respect to integer addition. *)
+Definition int_add_neg_r@{} (x : Int) : x - x = 0.
+Proof.
+  unfold "-"; by rewrite int_add_comm, int_add_neg_l.
+Defined.
+
+(** Negation distributes over addition. *)
+Definition int_neg_add@{} (x y : Int) : - (x + y) = - x - y.
+Proof.
+  induction x as [|x IHx|x IHx] in y |- *.
+  - reflexivity.
+  - rewrite int_add_succ_l.
+    rewrite 2 int_neg_succ.
+    rewrite int_add_pred_l.
+    f_ap.
+  - rewrite int_neg_pred.
+    rewrite int_add_succ_l.
+    rewrite int_add_pred_l.
+    rewrite int_neg_pred.
+    f_ap.
+Defined.
+      
+(** *** Multiplication *)
+
+(** Multiplication with a successor on the left is the sum of the multplication without the sucesseor and the multiplicand which was not a successor. *)
+Definition int_mul_succ_l@{} (x y : Int) : x.+1 * y = y + x * y.
+Proof.
+  induction x as [|[|x] IHx|[] IHx] in y |- *.
+  - reflexivity.
+  - reflexivity.
+  - reflexivity.
+  - cbn.
+    rewrite int_add_0_r.
+    by rewrite int_add_neg_r.
+  - rewrite int_pred_succ.
+    cbn.
+    rewrite int_add_assoc.
+    rewrite int_add_neg_r.
+    by rewrite int_add_0_l.
+Defined.
+
+(** Similarly, multiplication with a predecessor on the left is the sum of the multiplication without the predecessor and the negation of the multiplicand which was not a predecessor. *)
+Definition int_mul_pred_l@{} (x y : Int) : x.-1 * y = -y + x * y.
+Proof.
+  induction x as [|x IHx|[] IHx] in y |- *.
+  - reflexivity.
+  - rewrite int_mul_succ_l.
+    rewrite int_succ_pred.
+    rewrite int_add_assoc.
+    by rewrite int_add_neg_l.
+  - reflexivity.
+  - reflexivity.
+Defined.
+
+(** Integer multiplication with zero on the left is zero by definition. *)
+Definition int_mul_0_l@{} (x : Int) : 0 * x = 0 := 1.
+
+(** Integer multiplication with zero on the right is zero. *)
+Definition int_mul_0_r@{} (x : Int) : x * 0 = 0.
+Proof.
+  induction x as [|x IHx|x IHx].
+  - reflexivity.
+  - by rewrite int_mul_succ_l, int_add_0_l.
+  - by rewrite int_mul_pred_l, int_add_0_l.
+Defined.
+
+(** Integer multiplication with one on the left is the identity. *)
+Definition int_mul_1_l@{} (x : Int) : 1 * x = x.
+Proof.
+  apply int_add_0_r.
+Defined.
+
+(** Integer multiplication with one on the right is the identity. *)
+Definition int_mul_1_r@{} (x : Int) : x * 1 = x.
+Proof.
+  induction x as [|x IHx|x IHx].
+  - reflexivity.
+  - by rewrite int_mul_succ_l, IHx.
+  - by rewrite int_mul_pred_l, IHx.
+Defined. 
+
+(** Multiplying with a negation on the left is the same as negating the product. *)
+Definition int_mul_neg_l@{} (x y : Int) : - x * y = - (x * y).
+Proof.
+  induction x as [|x IHx|x IHx] in y |- *.
+  - reflexivity.
+  - rewrite int_neg_succ.
+    rewrite int_mul_pred_l.
+    rewrite int_mul_succ_l.
+    rewrite int_neg_add.
+    by rewrite IHx.
+  - rewrite int_neg_pred.
+    rewrite int_mul_succ_l.
+    rewrite int_mul_pred_l.
+    rewrite int_neg_add.
+    rewrite IHx.
+    by rewrite int_neg_neg.
+Defined.
+
+(** Multiplying with a successor on the right is the sum of the multiplication without the successor and the product of the multiplicand which was not a successor and the multiplicand. *)
+Definition int_mul_succ_r@{} (x y : Int) : x * y.+1 = x + x * y.
+Proof.
+  induction x as [|x IHx|x IHx] in y |- *.
+  - reflexivity.
+  - rewrite 2 int_mul_succ_l.
+    rewrite 2 int_add_succ_l.
+    f_ap.
+    rewrite IHx.
+    rewrite !int_add_assoc; f_ap.
+    by rewrite int_add_comm.
+  - rewrite 2 int_mul_pred_l.
+    rewrite int_neg_succ.
+    rewrite int_mul_neg_l.
+    rewrite 2 int_add_pred_l.
+    f_ap.
+    rewrite <- int_mul_neg_l.
+    rewrite IHx.
+    rewrite !int_add_assoc; f_ap.
+    by rewrite int_add_comm.
+Defined.
+
+(** Multiplying with a predecessor on the right is the sum of the multiplication without the predecessor and the product of the multiplicand which was not a predecessor and the negation of the multiplicand which was not a predecessor. *)
+Definition int_mul_pred_r@{} (x y : Int) : x * y.-1 = -x + x * y.
+Proof.
+  induction x as [|x IHx|x IHx] in y |- *.
+  - reflexivity.
+  - rewrite 2 int_mul_succ_l.
+    rewrite IHx.
+    rewrite !int_add_assoc; f_ap.
+    rewrite <- (int_neg_neg y.-1).
+    rewrite <- int_neg_add.
+    rewrite int_neg_pred.
+    rewrite int_add_succ_l.
+    rewrite int_add_comm.
+    rewrite <- int_add_succ_l.
+    rewrite int_neg_add.
+    by rewrite int_neg_neg.
+  - rewrite int_neg_pred.
+    rewrite int_neg_neg.
+    rewrite 2 int_mul_pred_l.
+    rewrite IHx.
+    rewrite !int_add_assoc; f_ap.
+    rewrite int_neg_pred.
+    rewrite int_neg_neg.
+    rewrite 2 int_add_succ_l; f_ap.
+    by rewrite int_add_comm.
+Defined.
+
+(** Integer multiplication is commutative. *)
+Definition int_mul_comm@{} (x y : Int) : x * y = y * x.
+Proof.
+  induction y as [|y IHy|y IHy] in x |- *.
+  - apply int_mul_0_r.
+  - rewrite int_mul_succ_l.
+    rewrite int_mul_succ_r.
+    by rewrite IHy.
+  - rewrite int_mul_pred_l.
+    rewrite int_mul_pred_r.
+    by rewrite IHy.
+Defined.
+
+(** Multiplying with a negation on the right is the same as negating the product. *)
+Definition int_mul_neg_r@{} (x y : Int) : x * - y = - (x * y).
+Proof.
+  rewrite !(int_mul_comm x).
+  apply int_mul_neg_l.
+Defined.
+
+(** Multiplication distributes over addition on the left. *)
+Definition int_dist_l@{} (x y z : Int) : x * (y + z) = x * y + x * z.
+Proof.
+  induction x as [|x IHx|x IHx] in y, z |- *.
+  - reflexivity.
+  - rewrite 3 int_mul_succ_l.
+    rewrite IHx.
+    rewrite !int_add_assoc; f_ap.
+    rewrite <- !int_add_assoc; f_ap.
+    by rewrite int_add_comm.
+  - rewrite 3 int_mul_pred_l.
+    rewrite IHx.
+    rewrite !int_add_assoc; f_ap.
+    rewrite int_neg_add.
+    rewrite <- !int_add_assoc; f_ap.
+    by rewrite int_add_comm.
+Defined.
+
+(** Multiplication distributes over addition on the right. *)
+Definition int_dist_r@{} (x y z : Int) : (x + y) * z = x * z + y * z.
+Proof.
+  by rewrite int_mul_comm, int_dist_l, !(int_mul_comm z).
+Defined.
+
+(** Multiplication is associative. *)
+Definition int_mul_assoc@{} (x y z : Int) : x * (y * z) = x * y * z.
+Proof.
+  induction x as [|x IHx|x IHx] in y, z |- *.
+  - reflexivity.
+  - rewrite 2 int_mul_succ_l.
+    rewrite int_dist_r.
+    by rewrite IHx.
+  - rewrite 2 int_mul_pred_l.
+    rewrite int_dist_r.
+    rewrite <- int_mul_neg_l.
+    by rewrite IHx.
+Defined.
+
+(** ** Iteration of equivalences *)
+
+(** *** Iteration by arbitrary integers *)
+
+(** Iteration by arbitrary integers requires the endofunction to be an equivalence, so that we can define a negative iteration by using its inverse. *)
+
+Definition int_iter {A} (f : A -> A) `{!IsEquiv f} (n : Int) : A -> A
+  := match n with
+      | negS n => fun x => nat_iter n.+1%nat f^-1 x
+      | zero => idmap
+      | posS n => fun x => nat_iter n.+1%nat f x
+     end.
+
+Definition int_iter_neg {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A)
+  : int_iter f (- n) a = int_iter f^-1 n a.
+Proof.
+  by destruct n.
+Defined.
+
+Definition int_iter_succ_l {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A)
+  : int_iter f (int_succ n) a = f (int_iter f n a).
+Proof.
+  induction n as [|n|n].
+  - reflexivity.
+  - by destruct n.
+  - rewrite int_pred_succ. 
+    destruct n.
+    all: symmetry; apply eisretr.
+Defined.
+
+Definition int_iter_succ_r {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A)
+  : int_iter f (int_succ n) a = int_iter f n (f a).
+Proof.
+  induction n as [|n|n].
+  - reflexivity.
+  - destruct n.
+    1: reflexivity.
+    cbn; f_ap.
+  - destruct n.
+    1: symmetry; apply eissect.
+    rewrite int_pred_succ.
+    apply (ap f^-1).
+    rhs_V nrapply IHn.
+    by destruct n.
+Defined.
+
+Definition int_iter_pred_l {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A)
+  : int_iter f (int_pred n) a = f^-1 (int_iter f n a).
+Proof.
+  (* Convert the problem to be a problem about [f^-1] and [-n]. *)
+  lhs_V exact (int_iter_neg f^-1 (n.-1) a).
+  rhs_V exact (ap f^-1 (int_iter_neg f^-1 n a)).
+  (* Then [int_iter_succ_l] applies, after changing [- n.-1] to [(-n).+1]. *)
+  rewrite int_neg_pred.
+  apply int_iter_succ_l.
+Defined.
+
+Definition int_iter_pred_r {A} (f : A -> A) `{IsEquiv _ _ f} (n : Int) (a : A)
+  : int_iter f (int_pred n) a = int_iter f n (f^-1 a).
+Proof.
+  (* Convert the problem to be a problem about [f^-1] and [-n]. *)
+  lhs_V exact (int_iter_neg f^-1 (n.-1) a).
+  rhs_V exact (int_iter_neg f^-1 n (f^-1 a)).
+  (* Then [int_iter_succ_r] applies, after changing [- n.-1] to [(-n).+1]. *)
+  rewrite int_neg_pred.
+  apply int_iter_succ_r.
+Defined.
+
+Definition int_iter_add {A} (f : A -> A) `{IsEquiv _ _ f} (m n : Int)
+  : int_iter f (m + n) == int_iter f m o int_iter f n.
+Proof.
+  intros a.
+  induction m as [|m|m].
+  - reflexivity.
+  - rewrite int_add_succ_l.
+    rewrite 2 int_iter_succ_l.
+    f_ap.
+  - rewrite int_add_pred_l.
+    rewrite 2 int_iter_pred_l.
+    f_ap.
+Defined.
+
+(** If [g : A -> A'] commutes with automorphisms of [A] and [A'], then it commutes with iteration. *)
+Definition int_iter_commute_map {A A'} (f : A -> A) `{!IsEquiv f}
+  (f' : A' -> A') `{!IsEquiv f'}
+  (g : A -> A') (p : g o f == f' o g) (n : Int) (a : A)
+  : g (int_iter f n a) = int_iter f' n (g a).
+Proof.
+  induction n as [|n IHn|n IHn] in a |- *.
+  - reflexivity.
+  - rewrite 2 int_iter_succ_r.
+    rewrite IHn.
+    f_ap.
+  - rewrite 2 int_iter_pred_r.
+    rewrite IHn.
+    f_ap.
+    apply moveL_equiv_V.
+    lhs_V nrapply p.
+    f_ap.
+    apply eisretr.
+Defined.
+
+(** In particular, homotopic maps have homotopic iterations. *)
+Definition int_iter_homotopic (n : Int) {A} (f f' : A -> A) `{!IsEquiv f} `{!IsEquiv f'}
+  (h : f == f')
+  : int_iter f n == int_iter f' n
+  := int_iter_commute_map f f' idmap h n.
+
+(** [int_iter f n x] doesn't depend on the proof that [f] is an equivalence. *)
+Definition int_iter_agree (n : Int) {A} (f : A -> A) {ief ief' : IsEquiv f}
+  : forall x, @int_iter A f ief n x = @int_iter A f ief' n x
+  := int_iter_homotopic n f f (fun _ => idpath).
+
+Definition int_iter_invariant (n : Int) {A} (f : A -> A) `{!IsEquiv f}
+  (P : A -> Type)
+  (Psucc : forall x, P x -> P (f x))
+  (Ppred : forall x, P x -> P (f^-1 x))
+  : forall x, P x -> P (int_iter f n x).
+Proof.
+  induction n as [|n IHn|n IHn]; intro x.
+  - exact idmap.
+  - intro H.
+    rewrite int_iter_succ_l.
+    apply Psucc, IHn, H.
+  - intro H.
+    rewrite int_iter_pred_l.
+    apply Ppred, IHn, H.
+Defined.
+
+(** ** Exponentiation of loops *)
+
+Definition loopexp {A : Type} {x : A} (p : x = x) (z : Int) : (x = x)
+  := int_iter (equiv_concat_r p x) z idpath.
+
+Definition loopexp_succ_r {A : Type} {x : A} (p : x = x) (z : Int)
+  : loopexp p z.+1 = loopexp p z @ p
+  := int_iter_succ_l _ _ _.
+
+Definition loopexp_pred_r {A : Type} {x : A} (p : x = x) (z : Int)
+  : loopexp p z.-1 = loopexp p z @ p^
+  := int_iter_pred_l _ _ _.
+
+Definition loopexp_succ_l {A : Type} {x : A} (p : x = x) (z : Int)
+  : loopexp p z.+1 = p @ loopexp p z.
+Proof.
+  lhs nrapply loopexp_succ_r.
+  induction z as [|z|z].
+  - nrapply concat_1p_p1.
+  - rewrite loopexp_succ_r.
+    rhs nrapply concat_p_pp.
+    f_ap.
+  - rewrite loopexp_pred_r.
+    lhs nrapply concat_pV_p.
+    rhs nrapply concat_p_pp.
+    by apply moveL_pV.
+Defined.
+
+Definition loopexp_pred_l {A : Type} {x : A} (p : x = x) (z : Int)
+  : loopexp p z.-1 = p^ @ loopexp p z.
+Proof.
+  rewrite loopexp_pred_r.
+  induction z as [|z|z].
+  - exact (concat_1p _ @ (concat_p1 _)^).
+  - rewrite loopexp_succ_r.
+    lhs nrapply concat_pp_V.
+    rhs nrapply concat_p_pp.
+    by apply moveL_pM.
+  - rewrite loopexp_pred_r.
+    rhs nrapply concat_p_pp.
+    f_ap.
+Defined.
+
+Definition ap_loopexp {A B} (f : A -> B) {x : A} (p : x = x) (z : Int)
+  : ap f (loopexp p z) = loopexp (ap f p) z.
+Proof.
+  nrapply int_iter_commute_map.
+  intro q; apply ap_pp.
+Defined.
+
+Definition loopexp_add {A : Type} {x : A} (p : x = x) m n
+  : loopexp p (m + n) = loopexp p m @ loopexp p n.
+Proof.
+  induction m as [|m|m].
+  - symmetry; apply concat_1p.
+  - rewrite int_add_succ_l.
+    rewrite 2 loopexp_succ_l.
+    by rewrite IHm, concat_p_pp.
+  - rewrite int_add_pred_l.
+    rewrite 2 loopexp_pred_l.
+    by rewrite IHm, concat_p_pp.
+Defined.
+
+(** Under univalence, exponentiation of loops corresponds to iteration of autoequivalences. *)
+
+Definition equiv_path_loopexp {A : Type} (p : A = A) (z : Int) (a : A)
+  : equiv_path A A (loopexp p z) a = int_iter (equiv_path A A p) z a.
+Proof.
+  refine (int_iter_commute_map _ _ (fun p => equiv_path A A p a) _ _ _).
+  intro q; cbn.
+  nrapply transport_pp.
+Defined.
+
+Definition loopexp_path_universe `{Univalence} {A : Type} (f : A <~> A)
+  (z : Int) (a : A)
+  : transport idmap (loopexp (path_universe f) z) a = int_iter f z a.
+Proof.
+  revert f. equiv_intro (equiv_path A A) p.
+  refine (_ @ equiv_path_loopexp p z a).
+  refine (ap (fun q => equiv_path A A (loopexp q z) a) _).
+  apply eissect.
+Defined.
+
+(** ** Converting between integers and naturals *)
+
+(** [int_of_nat] preserves successors. *)
+Definition int_nat_succ (n : nat)
+  : (n.+1)%int = (n.+1)%nat :> Int.
+Proof.
+  by induction n.
+Defined.
+
+(** [int_of_nat] preserves addition. Hence is a monoid homomorphism. *)
+Definition int_nat_add (n m : nat)
+  : (n + m)%int = (n + m)%nat :> Int.
+Proof.
+  induction n as [|n IHn].
+  - reflexivity.
+  - rewrite <- 2 int_nat_succ.
+    rewrite int_add_succ_l.
+    exact (ap _ IHn).
+Defined.
+
+(** [int_of_nat] preserves subtraction when not truncated. *)
+Definition int_nat_sub (n m : nat)
+  : (m <= n)%nat -> (n - m)%int = (n - m)%nat :> Int.
+Proof.
+  intros H.
+  induction H as [|n H IHn].
+  - lhs nrapply int_add_neg_r.
+    by rewrite nat_sub_cancel.
+  - rewrite nat_sub_succ_l; only 2: exact _.
+    rewrite <- 2 int_nat_succ.
+    rewrite int_add_succ_l.
+    exact (ap _ IHn).
+Defined.
+
+(** [int_of_nat] preserves multiplication. This makes [int_of_nat] a semiring homomorphism. *)
+Definition int_nat_mul (n m : nat)
+  :  (n * m)%int = (n * m)%nat :> Int.
+Proof.
+  induction n as [|n IHn].
+  - reflexivity.
+  - rewrite <- int_nat_succ.
+    rewrite int_mul_succ_l.
+    rewrite nat_mul_succ_l.
+    rhs_V nrapply int_nat_add.
+    exact (ap _ IHn).
+Defined.
diff --git a/theories/Spaces/Int/Spec.v b/theories/Spaces/Int/Spec.v
deleted file mode 100644
index cb1dc6b975b..00000000000
--- a/theories/Spaces/Int/Spec.v
+++ /dev/null
@@ -1,461 +0,0 @@
-Require Import Basics.
-Require Import Spaces.Pos.
-Require Import Spaces.Int.Core.
-
-Local Set Universe Minimization ToSet.
-
-Local Open Scope int_scope.
-
-(** ** Addition is commutative *)
-
-Lemma int_add_comm n m : n + m = m + n.
-Proof.
-  destruct n, m; cbn; trivial; by rewrite pos_add_comm.
-Qed.
-
-(** ** Zero is the additive identity. *)
-
-Lemma int_add_0_l n : 0 + n = n.
-Proof.
-  reflexivity.
-Qed.
-
-Lemma int_add_0_r n : n + 0 = n.
-Proof.
-  by destruct n.
-Qed.
-
-(** ** Multiplication by zero is zero *)
-
-Lemma int_mul_0_l n : 0 * n = 0.
-Proof.
-  reflexivity.
-Qed.
-
-Lemma int_mul_0_r n : n * 0 = 0.
-Proof.
-  by destruct n.
-Qed.
-
-(** ** One is the multiplicative identity *)
-
-Lemma int_mul_1_l n : 1 * n = n.
-Proof.
-  by destruct n.
-Qed.
-
-Lemma int_mul_1_r n : n * 1 = n.
-Proof.
-  destruct n; trivial; cbn; apply ap, pos_mul_1_r.
-Qed.
-
-(** ** Inverse laws *)
-
-Lemma int_pos_sub_diag n : int_pos_sub n n = 0.
-Proof.
-  induction n; trivial; cbn; by rewrite IHn.
-Qed.
-
-Lemma int_add_negation_l n : (-n) + n = 0.
-Proof.
-  destruct n; trivial; cbn; apply int_pos_sub_diag.
-Qed.
-
-Lemma int_add_negation_r n : n + (-n) = 0.
-Proof.
-  destruct n; trivial; cbn; apply int_pos_sub_diag.
-Qed.
-
-(** ** Permutation of neg and pos_succ *)
-Lemma int_neg_pos_succ p : neg (pos_succ p) = int_pred (neg p).
-Proof.
-  by destruct p.
-Qed.
-
-(** ** Permutation of pos and pos_succ *)
-Lemma int_pos_pos_succ p : pos (pos_succ p) = int_succ (pos p).
-Proof.
-  by destruct p.
-Qed.
-
-(** ** Negation of a doubled positive integer *)
-Lemma int_negation_double a
-  : - (int_double a) = int_double (- a).
-Proof.
-  by destruct a.
-Qed.
-
-(** Negation of the predecessor of a doubled positive integer. *)
-Lemma int_negation_pred_double a
-  : - (int_pred_double a) = int_succ_double (- a).
-Proof.
-  by destruct a.
-Qed.
-
-(** Negation of the doubling of the sucessor of an positive. *)
-Lemma int_negation_succ_double a
-  : - (int_succ_double a) = int_pred_double (- a).
-Proof.
-  by destruct a.
-Qed.
-
-(** Negation of subtraction of positive integers *)
-Lemma int_pos_sub_negation a b
-  : - (int_pos_sub a b) = int_pos_sub b a.
-Proof.
-  revert a b.
-  induction a as [|a ah|a ah];
-  destruct b;
-  cbn; trivial.
-  all: rewrite ?int_negation_double,
-    ?int_negation_succ_double,
-    ?int_negation_pred_double.
-  all: apply ap, ah.
-Qed.
-
-(** ** int_succ is a retract of int_pred *)
-Definition int_succ_pred : int_succ o int_pred == idmap.
-Proof.
-  intros [n | | n]; [|trivial|].
-  all: destruct n; trivial.
-  1,2: cbn; apply ap.
-  1: apply pos_pred_double_succ.
-  rewrite pos_add_1_r.
-  apply pos_succ_pred_double.
-Qed.
-
-(** ** int_pred is a retract of int_succ *)
-Definition int_pred_succ : int_pred o int_succ == idmap.
-Proof.
-  intros [n | | n]; [|trivial|].
-  all: destruct n; trivial.
-  1,2: cbn; apply ap.
-  1: rewrite pos_add_1_r.
-  1: apply pos_succ_pred_double.
-  apply pos_pred_double_succ.
-Qed.
-
-(* ** The successor autoequivalence. *)
-Global Instance isequiv_int_succ : IsEquiv int_succ | 0
-  := isequiv_adjointify int_succ _ int_succ_pred int_pred_succ.
-
-Definition equiv_int_succ : Int <~> Int
-  := Build_Equiv _ _ _ isequiv_int_succ.
-
-(** ** Negation distributes over addition *)
-Lemma int_negation_add_distr n m : - (n + m) = - n + - m.
-Proof.
- destruct n, m; simpl; trivial using int_pos_sub_negation.
-Qed.
-
-(** ** Negation is injective *)
-Lemma int_negation_inj n m : -n = -m -> n = m.
-Proof.
-  destruct n, m; simpl; intro H.
-  1: apply pos_inj in H.
-  2: apply pos_neq_zero in H.
-  3: apply pos_neq_neg in H.
-  4: apply  zero_neq_pos in H.
-  6: apply  zero_neq_neg in H.
-  7: apply  neg_neq_pos in H.
-  8: apply  neg_neq_zero in H.
-  9: apply  neg_inj in H.
-  all: by destruct H.
-Qed.
-
-(** ** Subtracting 1 from a sucessor gives the positive integer. *)
-Lemma int_pos_sub_succ_l a
-  : int_pos_sub (pos_succ a) 1%pos = pos a.
-Proof.
-  destruct a; trivial.
-  cbn; apply ap, pos_pred_double_succ.
-Qed.
-
-(** ** Subtracting a sucessor from 1 gives minus the integer. *)
-Lemma int_pos_sub_succ_r a
-  : int_pos_sub 1%pos (pos_succ a) = neg a.
-Proof.
-  destruct a; trivial.
-  cbn; apply ap, pos_pred_double_succ.
-Qed.
-
-(** ** Interaction of doubling functions and subtraction *)
-
-Lemma int_succ_double_int_pos_sub a b
-  : int_succ_double (int_pos_sub a (pos_succ b))
-    = int_pred_double (int_pos_sub a b).
-Proof.
-  revert a b.
-  induction a; induction b; trivial.
-  + cbn; apply ap.
-    by rewrite pos_pred_double_succ.
-  + destruct a; trivial.
-  + cbn; destruct (int_pos_sub a b); trivial.
-  + cbn.
-    rewrite <- IHa.
-    destruct (int_pos_sub a (pos_succ b)); trivial.
-  + destruct a; trivial.
-  + cbn; destruct (int_pos_sub a b); trivial.
-  + cbn.
-    rewrite IHa.
-    cbn; destruct (int_pos_sub a b); trivial.
-Qed.
-
-Lemma int_pred_double_int_pos_sub a b 
-  : int_pred_double (int_pos_sub (pos_succ a) b)
-    = int_succ_double (int_pos_sub a b).
-Proof.
-  revert a b.
-  induction a; induction b; trivial.
-  + by destruct b.
-  + by destruct b.
-  + cbn; by destruct (int_pos_sub a b).
-  + cbn; by destruct (int_pos_sub a b).
-  + cbn; apply ap.
-    by rewrite pos_pred_double_succ.
-  + cbn.
-    rewrite <- IHa.
-    by destruct (int_pos_sub (pos_succ a) b).
-  + cbn.
-    rewrite IHa.
-    by destruct (int_pos_sub a b).
-Qed.
-
-(** ** Subtractions cancel sucessors. *)
-Lemma int_pos_sub_succ_succ a b
-  : int_pos_sub (pos_succ a) (pos_succ b) = int_pos_sub a b.
-Proof.
-  rewrite <- 2 pos_add_1_r.
-  revert a b.
-  induction a; induction b; trivial.
-  1: destruct b; trivial.
-  { destruct b; trivial.
-    cbn; apply ap.
-    by rewrite pos_pred_double_succ. }
-  1: destruct a; trivial.
-  1: apply int_succ_double_int_pos_sub.
-  { destruct a; trivial.
-    cbn; apply ap, ap, pos_pred_double_succ. }
-  1: apply int_pred_double_int_pos_sub.
-  cbn; apply ap.
-  rewrite <- 2 pos_add_1_r.
-  apply IHa.
-Defined.
-
-(** ** Predecessor of a subtraction is the subtraction of a sucessor. *)
-Lemma int_pred_pos_sub_r a b
-  : int_pred (int_pos_sub a b) = int_pos_sub a (pos_succ b).
-Proof.
-  revert a.
-  induction b as [|b bH] using pos_peano_ind.
-  1: destruct a; trivial; destruct a; trivial.
-  intro a.
-  revert b bH.
-  induction a as [|a aH] using pos_peano_ind.
-  { intros b bH.
-    rewrite <- bH.
-    destruct b; trivial.
-    cbn; apply ap.
-    rewrite 2 pos_add_1_r.
-    rewrite pos_succ_pred_double.
-    rewrite pos_pred_double_succ.
-    trivial. }
-  intros b bH.
-  rewrite 2 int_pos_sub_succ_succ.
-  apply bH.
-Qed.
-
-(** ** Negation of the predecessor is an involution. *)
-Lemma int_negation_pred_negation_red x
-  : - int_pred (- int_pred x) = x.
-Proof.
-  destruct x as [x| |x]; trivial;
-  destruct x; trivial; cbn; apply ap.
-  1: apply pos_pred_double_succ.
-  rewrite pos_add_1_r.
-  apply pos_succ_pred_double.
-Qed.
-
-(** ** Predecessor of a sum is the sum with a predecessor *)
-Lemma int_pred_add_r a b
-  : int_pred (a + b) = a + int_pred b.
-Proof.
-  revert a b.
-  intros [a| |a] [b| |b]; trivial.
-  + cbn; apply ap.
-    by rewrite pos_add_assoc.
-  + revert a.
-    induction b as [|b bH] using pos_peano_ind.
-    - intro a; exact (int_pred_succ (neg a)).
-    - intro a.
-      rewrite <- pos_add_1_r.
-      rewrite (int_pred_succ (pos b)).
-      rewrite int_add_comm.
-      cbn.
-      rewrite pos_add_1_r.
-      rewrite <- int_pos_sub_negation.
-      rewrite <- int_pred_pos_sub_r.
-      apply int_negation_inj.
-      rewrite int_pos_sub_negation.
-      apply int_negation_pred_negation_red.
-  + cbn.
-    rewrite pos_add_1_r.
-    apply int_pred_pos_sub_r.
-  + revert a.
-    induction b as [|b bH] using pos_peano_ind.
-    - intro a; exact (int_pred_succ (pos a)).
-    - intro a.
-      rewrite <- pos_add_1_r.
-      rewrite (int_pred_succ (pos b)).
-      cbn; rewrite pos_add_assoc.
-      change (int_pred (int_succ (pos (a + b)%pos)) = pos a + pos b).
-      apply int_pred_succ.
-Qed.
-
-(** ** Subtraction from a sum is the sum of a subtraction *)
-Lemma int_pos_sub_add (a b c : Pos)
-  : int_pos_sub (a + b)%pos c = pos a + int_pos_sub b c.
-Proof.
-  revert c b a.
-  induction c as [|c ch] using pos_peano_ind.
-  { intros b a.
-    change (int_pred (pos a + pos b) = pos a + (int_pred (pos b))).
-    apply int_pred_add_r. }
-  intros b a.
-  rewrite <- int_pred_pos_sub_r.
-  rewrite ch.
-  rewrite <- int_pred_pos_sub_r.
-  apply int_pred_add_r.
-Qed.
-
-(** An auxillary lemma used to prove associativity. *)
-Lemma int_add_assoc_pos p n m : pos p + (n + m) = pos p + n + m.
-Proof.
-  destruct n as [n| |n], m as [m| |m]; trivial.
-  - cbn; apply int_negation_inj.
-    rewrite !int_negation_add_distr, !int_pos_sub_negation.
-    rewrite int_add_comm, pos_add_comm.
-    apply int_pos_sub_add.
-  - symmetry.
-    apply int_add_0_r.
-  - by rewrite <- int_pos_sub_add, int_add_comm,
-      <- int_pos_sub_add, pos_add_comm.
-  - symmetry.
-    apply int_pos_sub_add.
-  - cbn; apply ap, pos_add_assoc.
-Qed.
-
-(** ** Associativity of addition *)
-Lemma int_add_assoc n m p : n + (m + p) = n + m + p.
-Proof.
-  destruct n.
-  - apply int_negation_inj.
-    rewrite !int_negation_add_distr.
-    apply int_add_assoc_pos.
-  - trivial.
-  - apply int_add_assoc_pos.
-Qed.
-
-(** ** Relationship between [int_succ], [int_pred] and addition. *)
-Lemma int_add_succ_l a b : int_succ a + b = int_succ (a + b).
-Proof.
-  rewrite <- int_add_assoc, (int_add_comm 1 b).
-  apply int_add_assoc.
-Qed.
-
-Lemma int_add_succ_r a b : a + int_succ b = int_succ (a + b).
-Proof.
-  apply int_add_assoc.
-Qed.
-
-Lemma int_add_pred_l a b : int_pred a + b = int_pred (a + b).
-Proof.
-  rewrite <- int_add_assoc, (int_add_comm (-1) b).
-  apply int_add_assoc.
-Qed.
-
-Lemma int_add_pred_r a b : a + int_pred b = int_pred (a + b).
-Proof.
-  apply int_add_assoc.
-Qed.
-
-(** ** Commutativity of multiplication *)
-Lemma int_mul_comm n m : n * m = m * n.
-Proof.
-  destruct n, m; cbn; try reflexivity;
-  apply ap; apply pos_mul_comm.
-Qed.
-
-(** Distributivity of multiplication over addition *)
-
-Lemma int_pos_sub_mul_pos n m p
-  : int_pos_sub n m * pos p = int_pos_sub (n * p)%pos (m * p)%pos.
-Proof.
-  rewrite int_mul_comm.
-  rewrite 2 (pos_mul_comm _ p).
-  induction p.
-  { rewrite 2 pos_mul_1_l.
-    apply int_mul_1_l. }
-  { cbn.
-    rewrite <- IHp.
-    set (int_pos_sub n m) as k.
-    by destruct k. }
-  cbn.
-  rewrite int_pos_sub_add.
-  rewrite <- (int_pos_sub_negation _ (x0 _)).
-  rewrite int_pos_sub_add.
-  rewrite int_negation_add_distr.
-  rewrite int_pos_sub_negation.
-  rewrite int_add_assoc.
-  cbn.
-  rewrite <- IHp.
-  set (int_pos_sub n m) as k.
-  by destruct k.
-Qed.
-
-Lemma int_pos_sub_mul_neg n m p
-  : int_pos_sub m n  * neg p = int_pos_sub (n * p)%pos (m * p)%pos.
-Proof.
-  rewrite int_mul_comm.
-  rewrite 2 (pos_mul_comm _ p).
-  induction p.
-  { rewrite 2 pos_mul_1_l.
-    rewrite <- int_pos_sub_negation.
-    by destruct (int_pos_sub n m). }
-  { cbn.
-    rewrite <- IHp.
-    rewrite <- int_pos_sub_negation.
-    set (int_pos_sub n m) as k.
-    by destruct k. }
-  cbn.
-  rewrite int_pos_sub_add.
-  rewrite <- (int_pos_sub_negation _ (x0 _)).
-  rewrite int_pos_sub_add.
-  rewrite int_negation_add_distr.
-  rewrite int_pos_sub_negation.
-  rewrite int_add_assoc.
-  cbn.
-  rewrite <- IHp.
-  rewrite <- (int_pos_sub_negation m).
-  set (int_pos_sub m n) as k.
-  by destruct k.
-Qed.
-
-Lemma int_mul_add_distr_r n m p : (n + m) * p = n * p + m * p.
-Proof.
-  induction p; destruct n, m; cbn; trivial; try f_ap;
-  try apply pos_mul_add_distr_r;
-  try apply int_pos_sub_mul_neg;
-  try apply int_pos_sub_mul_pos;
-  apply int_mul_0_r.
-Qed.
-
-Lemma int_mul_add_distr_l n m p : n * (m + p) = n * m + n * p.
-Proof.
-  rewrite 3 (int_mul_comm n); apply int_mul_add_distr_r.
-Qed.
-
-Lemma int_mul_assoc n m p : n * (m * p) = n * m * p.
-Proof.
-  destruct n, m, p; cbn; trivial; f_ap; apply pos_mul_assoc.
-Qed.
diff --git a/theories/Spaces/List.v b/theories/Spaces/List.v
deleted file mode 100644
index 0fa3ccabd9e..00000000000
--- a/theories/Spaces/List.v
+++ /dev/null
@@ -1,45 +0,0 @@
-Require Import Basics.Overture Basics.Tactics.
-
-Local Open Scope list_scope.
-
-(** ** Lemmas about lists *)
-
-(** Note that [list] is currently defined in Basics.Datatypes. *)
-
-Section Fold_Left_Recursor.
-  Variables (A : Type) (B : Type).
-  Variable f : A -> B -> A.
-
-  Fixpoint fold_left (l : list B) (a0 : A) : A :=
-    match l with
-      | nil => a0
-      | cons b t => fold_left t (f a0 b)
-    end.
-
-  Lemma fold_left_app : forall (l l' : list B) (i : A),
-    fold_left (l ++ l') i = fold_left l' (fold_left l i).
-  Proof.
-    induction l; simpl; auto.
-  Qed.
-
-End Fold_Left_Recursor.
-
-Section Fold_Right_Recursor.
-  Variables (A : Type) (B : Type).
-  Variable f : B -> A -> A.
-
-  Fixpoint fold_right (a0 : A) (l : list B) : A :=
-    match l with
-      | nil => a0
-      | cons b t => f b (fold_right a0 t)
-    end.
-
-  Lemma fold_right_app : forall l l' i,
-    fold_right i (l ++ l') = fold_right (fold_right i l') l.
-  Proof.
-    induction l; simpl; auto.
-    intros; f_ap.
-  Qed.
-
-End Fold_Right_Recursor.
-
diff --git a/theories/Spaces/List/Core.v b/theories/Spaces/List/Core.v
new file mode 100644
index 00000000000..d8fec4c5761
--- /dev/null
+++ b/theories/Spaces/List/Core.v
@@ -0,0 +1,204 @@
+Require Import Basics.Overture.
+
+Local Unset Elimination Schemes.
+Local Set Universe Minimization ToSet.
+Local Set Polymorphic Inductive Cumulativity.
+
+(** * Lists *)
+
+(** ** Definition *)
+
+Declare Scope list_scope.
+Local Open Scope list_scope.
+
+(** A list is a sequence of elements from a type [A]. This is a very useful datatype and has many applications ranging from programming to algebra. It can be thought of a free monoid. *)
+Inductive list@{i|} (A : Type@{i}) : Type@{i} :=
+| nil : list A
+| cons : A -> list A -> list A.
+
+Arguments nil {A}.
+Arguments cons {A} _ _.
+
+Delimit Scope list_scope with list.
+Bind Scope list_scope with list.
+
+(** This messes with Coq's parsing of [] in ltac. Therefore we keep it commented out. It's not difficult to write [nil] instead. *)
+(* Notation "[]" := nil : list_scope. *)
+Infix "::" := cons : list_scope.
+
+Scheme list_rect := Induction for list Sort Type.
+Scheme list_ind := Induction for list Sort Type.
+Scheme list_rec := Minimality for list Sort Type.
+
+(** A tactic for doing induction over a list that avoids spurious universes. *)
+Ltac simple_list_induction l h t IH :=
+  try generalize dependent l;
+  fix IH 1;
+  intros [| h t];
+  [ clear IH | specialize (IH t) ].
+
+(** Syntactic sugar for creating lists. [ [a1, b2, ..., an] = a1 :: b2 :: ... :: an :: nil ]. *)
+Notation "[ x ]" := (x :: nil) : list_scope.
+Notation "[ x , y , .. , z ]" := (x :: (y :: .. (z :: nil) ..)) : list_scope.
+
+(** ** Length *)
+
+(** Notice that the definition of a list looks very similar to the definition of [nat]. It is as if each [S] constructor from [nat] has an element of [A] attached to it. We can discard this extra element and get a list invariant that we call [length]. *)
+
+(** The length (number of elements) of a list. *)
+Fixpoint length {A : Type} (l : list A) :=
+  match l with
+  | nil => O
+  | _ :: l => S (length l)
+  end.
+
+(** ** Concatenation *)
+
+(** Given two lists [ [a1; a2; ...; an] ] and [ [b1; b2; ...; bm] ], we can concatenate them to get [ [a1; a2; ...; an; b1; b2; ...; bm] ]. *)
+Definition app {A : Type} : list A -> list A -> list A :=
+  fix app l m :=
+  match l with
+   | nil => m
+   | a :: l1 => a :: app l1 m
+  end.
+
+Infix "++" := app : list_scope.
+
+(** ** Folding *)
+
+(** Folding is a very important operation on lists. It is a way to reduce a list to a single value. The [fold_left] function starts from the left and the [fold_right] function starts from the right. *)
+
+(** [fold_left f l a0] computes [f (... (f (f a0 x1) x2) ...) xn] where [l = [x1; x2; ...; xn]]. *)
+Fixpoint fold_left {A B} (f : A -> B -> A) (l : list B) (default : A) : A :=
+  match l with
+    | nil => default
+    | cons b l => fold_left f l (f default b)
+  end.
+
+(** [fold_right f a0 l] computes [f x1 (f x2 ... (f xn a0) ...)] where [l = [x1; x2; ...; xn]]. *)
+Fixpoint fold_right {A B} (f : B -> A -> A) (default : A) (l : list B) : A :=
+  match l with
+    | nil => default
+    | cons b l => f b (fold_right f default l)
+  end.
+
+(** ** Maps - Functoriality of Lists *)
+
+(** The [list_map] function applies a function to each element of a list. In other words [ list_map f [a1; a2; ...; an] = [f a1; f a2; ...; f an] ]. *)
+Fixpoint list_map {A B : Type} (f : A -> B) (l : list A) :=
+  match l with
+  | nil => nil
+  | x :: l => (f x) :: (list_map f l)
+  end.
+
+(** The [list_map2] function applies a binary function to corresponding elements of two lists. When one of the lists run out, it uses one of the default functions to fill in the rest. *)
+Fixpoint list_map2 {A B C : Type} (f : A -> B -> C)
+  (def_l : list A -> list C) (def_r : list B -> list C) l1 l2 :=
+  match l1, l2 with
+  | nil, nil => nil
+  | nil, _ => def_r l2
+  | _, nil => def_l l1
+  | x :: l1, y :: l2 => (f x y) :: (list_map2 f def_l def_r l1 l2)
+  end.
+
+(** ** Reversal *)
+
+(** Tail-recursive list reversal. *)
+Fixpoint reverse_acc {A : Type} (acc : list A) (l : list A) : list A :=
+  match l with
+  | nil => acc
+  | x :: l => reverse_acc (x :: acc) l
+  end.
+
+(** Reversing the order of a list. The list [ [a1; a2; ...; an] ] becomes [ [an; ...; a2; a1] ]. *)
+Definition reverse {A : Type} (l : list A) : list A := reverse_acc nil l.
+
+(** ** Getting Elements *)
+
+(** The head of a list is its first element. Returns [None] If the list is empty. *)
+Definition head {A : Type} (l : list A) : option A :=
+  match l with
+  | nil => None
+  | a :: _ => Some a
+  end.
+
+(** The tail of a list is the list without its first element. *)
+Definition tail {A : Type} (l : list A) : list A :=
+  match l with
+    | nil => nil
+    | a :: m => m
+  end.
+
+(** The last element of a list. If the list is empty, it returns [None]. *)
+Fixpoint last {A : Type} (l : list A) : option A :=
+  match l with
+  | nil => None
+  | a :: nil => Some a
+  | _ :: l => last l
+  end.
+
+(** The [n]-th element of a list. If the list is too short, it returns [None]. *)
+Fixpoint nth {A : Type} (l : list A) (n : nat) : option A :=
+  match n, l with
+  | O, x :: _ => Some x
+  | S n, _ :: l => nth l n
+  | _, _ => None
+  end.
+
+(** ** Removing Elements *)
+
+(** Remove the last element of a list and do nothing if it is empty. *)
+Fixpoint remove_last {A : Type} (l : list A) : list A :=
+  match l with
+  | nil => nil
+  | _ :: nil => nil
+  | x :: l => x :: remove_last l
+  end.
+
+(** ** Sequences *)
+
+(** Descending sequence of natural numbers starting from [n.-1] to [0]. *)
+Fixpoint seq_rev (n : nat) : list nat :=
+    match n with
+    | O => nil
+    | S n => n :: seq_rev n
+    end.
+
+(** Ascending sequence of natural numbers [< n]. *)
+Definition seq (n : nat) : list nat := reverse (seq_rev n).
+
+(** ** Repeat *)
+
+(** Repeat an element [n] times. *)
+Fixpoint repeat {A : Type} (x : A) (n : nat) : list A :=
+  match n with
+  | O => nil
+  | S n => x :: repeat x n
+  end.
+
+(** ** Membership Predicate *)
+
+(** The "In list" predicate *)
+Fixpoint InList@{i|} {A : Type@{i}} (a : A) (l : list A) : Type@{i} :=
+  match l with
+    | nil => Empty
+    | b :: m => (b = a) + InList a m
+  end.
+
+(** ** Forall *)
+
+(** Apply a predicate to all elements of a list and take their conjunction. *)
+Fixpoint for_all@{i j|} {A : Type@{i}} (P : A -> Type@{j}) l : Type@{j} :=
+  match l with
+  | nil => Unit
+  | x :: l => P x /\ for_all P l
+  end.
+
+(** ** Exists *)
+
+(** Apply a predicate to all elements of a list and take their disjunction. *)
+Fixpoint list_exists@{i j|} {A : Type@{i}} (P : A -> Type@{j}) l : Type@{j} :=
+  match l with
+  | nil => Empty
+  | x :: l => P x + list_exists P l
+  end.
diff --git a/theories/Spaces/List/Paths.v b/theories/Spaces/List/Paths.v
new file mode 100644
index 00000000000..48e060d04e5
--- /dev/null
+++ b/theories/Spaces/List/Paths.v
@@ -0,0 +1,103 @@
+Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Trunc.
+Require Import Basics.Equivalences Types.Empty Types.Unit Types.Prod.
+Require Import Modalities.ReflectiveSubuniverse Truncations.Core.
+Require Import Spaces.List.Core.
+
+(** * Path spaces of lists *)
+
+(** This proof was adapted from a proof given in agda/cubical by Evan Cavallo. *)
+
+Section PathList.
+  Context {A : Type}.
+  
+  (** This type is equivalent to the path space of lists. We don't actually show that it is equivalent to the type of paths but rather that the path type is a retract of this type. This is sufficient to determine the h-level of the type of lists. *)
+  Fixpoint ListEq (l l' : list A) : Type :=
+    match l, l' with
+      | nil, nil => Unit
+      | cons x xs, cons x' xs' => (x = x') * ListEq xs xs'
+      | _, _ => Empty
+    end.
+
+  Global Instance reflexive_listeq : Reflexive ListEq. 
+  Proof.
+    intros l.
+    induction l as [| a l IHl].
+    - exact tt.
+    - exact (idpath, IHl).
+  Defined.
+
+  Local Definition encode {l1 l2} (p : l1 = l2) : ListEq l1 l2.
+  Proof.
+    by destruct p.
+  Defined.
+
+  Local Definition decode {l1 l2} (q : ListEq l1 l2) : l1 = l2.
+  Proof.
+    induction l1 as [| a l1 IHl1 ] in l2, q |- *.
+    1: by destruct l2.
+    destruct l2.
+    1: contradiction.
+    destruct q as [p q].
+    exact (ap011 (cons (A:=_)) p (IHl1 _ q)).
+  Defined.
+
+  Local Definition decode_refl {l} : decode (reflexivity l) = idpath.
+  Proof.
+    induction l.
+    1: reflexivity.
+    exact (ap02 (cons a) IHl).
+  Defined.
+
+  Local Definition decode_encode {l1 l2} (p : l1 = l2)
+    : decode (encode p) = p.
+  Proof.
+    destruct p.
+    apply decode_refl.
+  Defined.
+
+  (** By case analysis on both lists, it's easy to show that [ListEq] is [n.+1]-truncated if [A] is [n.+2]-truncated. *)
+  Global Instance istrunc_listeq n {l1 l2} {H : IsTrunc n.+2 A}
+    : IsTrunc n.+1 (ListEq l1 l2).
+  Proof.
+    induction l1 in l2 |- *.
+    - destruct l2.
+      1,2: exact _.
+    - destruct l2.
+      1: exact _.
+      rapply istrunc_prod.
+  Defined.
+
+  (** The path space of lists is a retract of [ListEq], therefore it is [n.+1]-truncated if [ListEq] is [n.+1]-truncated. By the previous result, this holds when [A] is [n.+2]-truncated. *) 
+  Global Instance istrunc_list n {H : IsTrunc n.+2 A} : IsTrunc n.+2 (list A).
+  Proof.
+    apply istrunc_S.
+    intros x y.
+    rapply (inO_retract_inO n.+1 _ _ encode decode decode_encode).
+  Defined.
+
+  (** With a little more work, we can show that [ListEq] is also a retract of the path space. *)
+  Local Definition encode_decode {l1 l2} (p : ListEq l1 l2)
+    : encode (decode p) = p.
+  Proof.
+    induction l1 in l2, p |- *.
+    1: destruct l2; by destruct p.
+    destruct l2.
+    1: by destruct p.
+    cbn in p.
+    destruct p as [r p].
+    apply path_prod.
+    - simpl.
+      destruct (decode p).
+      by destruct r.
+    - rhs_V nrapply IHl1.
+      simpl.
+      destruct (decode p).
+      by destruct r.
+  Defined.
+
+  (** Giving us a way of characterising paths in lists. *)
+  Definition equiv_path_list {l1 l2}
+    : ListEq l1 l2 <~> l1 = l2
+    := equiv_adjointify decode encode decode_encode encode_decode.
+
+End PathList.
diff --git a/theories/Spaces/List/Theory.v b/theories/Spaces/List/Theory.v
new file mode 100644
index 00000000000..b20ccc15f61
--- /dev/null
+++ b/theories/Spaces/List/Theory.v
@@ -0,0 +1,1181 @@
+Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids Basics.Trunc
+  Basics.Equivalences Basics.Decidable Basics.Iff.
+Require Import Types.Paths Types.Unit Types.Prod Types.Sigma Types.Sum
+  Types.Empty Types.Option.
+Require Export Spaces.List.Core Spaces.Nat.Core.
+
+Local Set Universe Minimization ToSet.
+Local Set Polymorphic Inductive Cumulativity.
+
+(** * Theory of Lists and List Operations *)
+
+(** In this file we collect lemmas about lists and their operations. We don't include those in [List.Core] so that file can stay lightweight on dependencies. *)
+
+(** We generally try to keep the order the same as the concepts appeared in [List.Core]. *)
+
+Local Open Scope list_scope.
+
+(** ** Length *)
+
+(** A list of length zero must be the empty list. *)
+Definition length_0 {A : Type} (l : list A) (H : length l = 0%nat)
+  : l = nil.
+Proof.
+  destruct l.
+  - reflexivity.
+  - discriminate.
+Defined.
+
+(** ** Concatenation *)
+
+(** Concatenating the empty list on the right is the identity. *)
+Definition app_nil {A : Type} (l : list A)
+  : l ++ nil = l.
+Proof.
+  induction l as [|a l IHl].
+  1: reflexivity.
+  simpl; f_ap.
+Defined.
+
+(** Associativity of list concatenation. *)
+Definition app_assoc {A : Type} (x y z : list A)
+  : app x (app y z) = app (app x y) z.
+Proof.
+  induction x as [|a x IHx] in |- *.
+  - reflexivity.
+  - exact (ap (cons a) IHx).
+Defined.
+
+(** The type of lists has a monoidal structure given by concatenation. *)
+Definition list_pentagon {A : Type} (w x y z : list A)
+  : app_assoc w x (y ++ z) @ app_assoc (w ++ x) y z
+    = ap (fun l => w ++ l) (app_assoc x y z)
+    @ app_assoc w (x ++ y) z
+    @ ap (fun l => l ++ z) (app_assoc w x y).
+Proof.
+  symmetry.
+  induction w as [|? w IHw] in x, y, z |- *.
+  - simpl.
+    apply equiv_p1_1q.
+    lhs nrapply concat_p1.
+    apply ap_idmap.
+  - simpl.
+    rhs_V nrapply ap_pp.
+    rhs_V nrapply (ap (ap (cons a)) (IHw x y z)).
+    rhs nrapply ap_pp.
+    f_ap.
+    { rhs nrapply ap_pp.
+      f_ap.
+      apply ap_compose. }
+    lhs_V nrapply ap_compose.
+    nrapply (ap_compose (fun l => l ++ z)).
+Defined.
+
+(** The length of a concatenated list is the sum of the lengths of the two lists. *)
+Definition length_app {A : Type} (l l' : list A)
+  : length (l ++ l') = (length l + length l')%nat.
+Proof.
+  induction l as [|a l IHl] using list_ind.
+  1: reflexivity.
+  simpl.
+  exact (ap S IHl).
+Defined.
+
+(** An element of a concatenated list is equivalently either in the first list or in the second list. *)
+Definition equiv_inlist_app {A : Type} (l l' : list A) (x : A)
+  : InList x l + InList x l' <~> InList x (l ++ l').
+Proof.
+  induction l as [|a l IHl].
+  - apply sum_empty_l.
+  - cbn; nrefine (_ oE equiv_sum_assoc _ _ _).
+    by apply equiv_functor_sum_l.
+Defined.
+
+(** ** Folding *)
+
+(** A left fold over a concatenated list is equivalent to folding over the first followed by folding over the second. *)
+Lemma fold_left_app {A B : Type} (f : A -> B -> A) (l l' : list B) (i : A)
+  : fold_left f (l ++ l') i = fold_left f l' (fold_left f l i).
+Proof.
+  induction l in i |- *.
+  1: reflexivity.
+  apply IHl.
+Defined.
+
+(** A right fold over a concatenated list is equivalent to folding over the second followed by folding over the first. *)
+Lemma fold_right_app {A B : Type} (f : B -> A -> A) (i : A) (l l' : list B)
+  : fold_right f i (l ++ l') = fold_right f (fold_right f i l') l.
+Proof.
+  induction l in i |- *.
+  1: reflexivity.
+  exact (ap (f a) (IHl _)).
+Defined.
+
+(** ** Maps *)
+
+(** The length of a mapped list is the same as the length of the original list. *)
+Definition length_list_map {A B : Type} (f : A -> B) (l : list A)
+  : length (list_map f l) = length l.
+Proof.
+  induction l as [|x l IHl] using list_ind.
+  - reflexivity.
+  - simpl.
+    exact (ap S IHl).
+Defined.
+
+(** A function applied to an element of a list is an element of the mapped list. *)
+Definition inlist_map {A B : Type} (f : A -> B) (l : list A) (x : A)
+  : InList x l -> InList (f x) (list_map f l).
+Proof.
+  simple_list_induction l y l IHl.
+  1: contradiction.
+  intros [p | i].
+  - left.  exact (ap f p).
+  - right. exact (IHl i).
+Defined.
+
+(** An element of a mapped list is equal to the function applied to some element of the original list. *)
+Definition inlist_map' {A B : Type} (f : A -> B) (l : list A) (x : B)
+  : InList x (list_map f l) -> { y : A & (f y = x) * InList y l }.
+Proof.
+  induction l as [|y l IHl].
+  1: contradiction.
+  intros [p | i].
+  - exact (y; (p, inl idpath)).
+  - destruct (IHl i) as [y' [p i']].
+    exact (y'; (p, inr i')).
+Defined.
+
+(** Mapping a function over a concatenated list is the concatenation of the mapped lists. *)
+Definition list_map_app {A B : Type} (f : A -> B) (l l' : list A)
+  : list_map f (l ++ l') = list_map f l ++ list_map f l'.
+Proof.
+  induction l as [|a l IHl].
+  1: reflexivity.
+  simpl; f_ap.
+Defined.
+
+(** A function that acts as the identity on the elements of a list is the identity on the mapped list. *)
+Lemma list_map_id {A : Type} (f : A -> A) (l : list A)
+  (Hf : forall x, InList x l -> f x = x)
+  :  list_map f l = l.
+Proof.
+  induction l as [|x l IHl].
+  - reflexivity.
+  - simpl.
+    nrapply ap011.
+    + exact (Hf _ (inl idpath)).
+    + apply IHl.
+      intros y Hy.
+      apply Hf.
+      by right.
+Defined.
+
+(** A [list_map] of a composition is the composition of the maps. *)
+Definition list_map_compose {A B C} (f : A -> B) (g : B -> C) (l : list A)
+  : list_map (fun x => g (f x)) l = list_map g (list_map f l).
+Proof.
+  induction l as [|a l IHl].
+  1: reflexivity.
+  simpl; f_ap.
+Defined.
+
+(** TODO: generalize as max *)
+(** The length of a [list_map2] is the same as the length of the original lists. *)
+Definition length_list_map2@{i j k|} {A : Type@{i}} {B : Type@{j}} {C : Type@{k}}
+  (f : A -> B -> C) defl defr l1 l2
+  : length l1 = length l2
+    -> length (list_map2 f defl defr l1 l2) = length l1.
+Proof.
+  intros p.
+  induction l1 as [|x l1 IHl1] in l2, p |- * using list_ind@{i j}.
+  - destruct l2.
+    + reflexivity.
+    + inversion p.
+  - destruct l2.
+    + inversion p.
+    + cbn; f_ap.
+      by apply IHl1, path_nat_succ.
+Defined.
+
+(** An element of a [list_map2] is the result of applying the function to some elements of the original lists. *)
+Definition inlist_map2@{i j k u | i <= u, j <= u, k <= u}
+  {A : Type@{i}} {B : Type@{j}} {C : Type@{k}}
+  (f : A -> B -> C) defl defr l1 l2 x
+  : InList x (list_map2 f defl defr l1 l2) -> length l1 = length l2
+    -> { y : A & { z : B &
+                        prod@{k u} ((f y z) = x) (InList y l1 * InList z l2) } }.
+Proof.
+  intros H p.
+  induction l1 as [|y l1 IHl1] in l2, x, H, p |- * using list_ind@{i u}.
+  - destruct l2.
+    1: contradiction.
+    inversion p.
+  - destruct l2 as [| z].
+    1: inversion p.
+    destruct H as [q | i].
+    1: exact (y; z; (q, (inl idpath, inl idpath))).
+    destruct (IHl1 l2 x i) as [y' [z' [q [r s]]]].
+    1: apply path_nat_succ, p.
+    exact (y'; z'; (q, (inr r, inr s))).
+Defined.
+
+(** [list_map2] is a [list_map] if the first list is a repeated value. *)
+Definition list_map2_repeat_l {A B C} (f : A -> B -> C) (x : A) l {defl defr}
+  : list_map2 f defl defr (repeat x (length l)) l = list_map (f x) l.
+Proof.
+  induction l as [|y l IHl].
+  - reflexivity.
+  - cbn; f_ap.
+Defined.
+
+(** [list_map2] is a [list_map] if the second list is a repeated value. *)
+Definition list_map2_repeat_r {A B C} (f : A -> B -> C) (y : B) l {defl defr}
+  : list_map2 f defl defr l (repeat y (length l)) = list_map (fun x => f x y) l.
+Proof.
+  induction l as [|x l IHl].
+  - reflexivity.
+  - cbn; f_ap.
+Defined.
+
+(** ** Reversal *)
+
+(** The length of [reverse_acc] is the sum of the lengths of the two lists. *)
+Definition length_reverse_acc@{i|} {A : Type@{i}} (acc l : list A)
+  : length (reverse_acc acc l) = (length acc + length l)%nat.
+Proof.
+  symmetry.
+  induction l as [|x l IHl] in acc |- * using list_ind@{i i}.
+  - apply nat_add_zero_r.
+  - rhs_V nrapply IHl.
+    apply nat_add_succ_r.
+Defined.
+
+(** The length of [reverse] is the same as the length of the original list. *)
+Definition length_reverse {A : Type} (l : list A)
+  : length (reverse l) = length l.
+Proof.
+  rapply length_reverse_acc.
+Defined.
+
+(** The [list_map] of a [reverse_acc] is the [reverse_acc] of the [list_map] of the two lists. *)
+Definition list_map_reverse_acc {A B : Type}
+  (f : A -> B) (l l' : list A)
+  : list_map f (reverse_acc l' l) = reverse_acc (list_map f l') (list_map f l).
+Proof.
+  revert l'; simple_list_induction l a l IHl; intro l'.
+  1: reflexivity.
+  apply IHl.
+Defined.
+
+(** The [list_map] of a reversed list is the reversed [list_map]. *)
+Definition list_map_reverse {A B} (f : A -> B) (l : list A)
+  : list_map f (reverse l) = reverse (list_map f l).
+Proof.
+  nrapply list_map_reverse_acc.
+Defined.
+
+(** [reverse_acc] is the same as concatenating the reversed list with the accumulator. *)
+Definition reverse_acc_cons {A : Type} (l l' : list A)
+  : reverse_acc l' l = reverse l ++ l'.
+Proof.
+  induction l as [|a l IHl] in l' |- *.
+  1: reflexivity.
+  lhs nrapply IHl.
+  lhs nrapply (app_assoc _ [a]).
+  f_ap; symmetry.
+  apply IHl.
+Defined.
+
+(** The [reverse] of a [cons] is the concatenation of the [reverse] with the head. *) 
+Definition reverse_cons {A : Type} (a : A) (l : list A)
+  : reverse (a :: l) = reverse l ++ [a].
+Proof.
+  induction l as [|b l IHl] in a |- *.
+  1: reflexivity.
+  rewrite IHl.
+  rewrite <- app_assoc.
+  cbn; apply reverse_acc_cons.
+Defined.
+
+(** The [reverse] of a concatenated list is the concatenation of the reversed lists in reverse order. *)
+Definition reverse_app {A : Type} (l l' : list A)
+  : reverse (l ++ l') = reverse l' ++ reverse l.
+Proof.
+  induction l as [|a l IHl] in l' |- *.
+  1: symmetry; apply app_nil.
+  simpl.
+  lhs nrapply reverse_cons.
+  rhs nrapply ap.
+  2: nrapply reverse_cons.
+  rhs nrapply app_assoc.
+  nrapply (ap (fun l => l ++ [a])).
+  exact (IHl l').
+Defined.
+
+(** [reverse] is involutive. *)
+Definition reverse_reverse {A : Type} (l : list A)
+  : reverse (reverse l) = l.
+Proof.
+  induction l.
+  1: reflexivity.
+  lhs nrapply ap.
+  1: nrapply reverse_cons.
+  lhs nrapply reverse_app.
+  exact (ap _ IHl).
+Defined.
+
+(** ** Getting elements *)
+
+(** A variant of [nth] that returns an element of the list and a proof that it is the [n]-th element. *)
+Definition nth_lt@{i|} {A : Type@{i}} (l : list A) (n : nat)
+  (H : (n < length l)%nat)
+  : { x : A & nth l n = Some x }.
+Proof.
+  induction l as [|a l IHa] in n, H |- * using list_ind@{i i}.
+  1: destruct (not_lt_zero_r _ H).
+  destruct n.
+  1: by exists a.
+  apply IHa.
+  apply leq_pred'.
+  exact H.
+Defined.
+
+(** A variant of [nth] that always returns an element when we know that the index is in the list. *)
+Definition nth' {A : Type} (l : list A) (n : nat) (H : (n < length l)%nat) : A
+  := pr1 (nth_lt l n H).
+
+(** The [nth'] element doesn't depend on the proof that [n < length l]. *)
+Definition nth'_nth' {A} (l : list A) (n : nat) (H H' : (n < length l)%nat)
+  : nth' l n H = nth' l n H'.
+Proof.
+  apply ap, path_ishprop.
+Defined.
+
+(** The [nth'] element of a list is in the list. *)
+Definition inlist_nth'@{i|} {A : Type@{i}} (l : list A) (n : nat)
+  (H : (n < length l)%nat)
+  : InList (nth' l n H) l.
+Proof.
+  induction l as [|a l IHa] in n, H |- * using list_ind@{i i}.
+  1: destruct (not_lt_zero_r _ H).
+  destruct n.
+  1: by left.
+  right.
+  apply IHa.
+Defined.
+
+(** The [nth'] element of a list is the same as the one given by [nth]. *)
+Definition nth_nth' {A} (l : list A) (n : nat) (H : (n < length l)%nat)
+  : nth l n = Some (nth' l n H).
+Proof.
+  exact (nth_lt l n H).2.
+Defined.
+
+(** The [nth'] element of a [cons] indexed at [n.+1] is the same as the [nth'] element of the tail indexed at [n]. *)
+Definition nth'_cons {A : Type} (l : list A) (n : nat) (x : A)
+  (H : (n < length l)%nat) (H' : (n.+1 < length (x :: l))%nat)
+  : nth' (x :: l) n.+1 H' = nth' l n H.
+Proof.
+  apply isinj_some.
+  nrefine (_^ @ _ @ _).  
+  1,3: rapply nth_nth'.
+  reflexivity.
+Defined.
+
+(** The index of an element in a list is the [n] such that the [nth'] element is the element. *)
+Definition index_of@{i|} {A : Type@{i}} (l : list A) (x : A)
+  : InList x l
+    -> sig@{Set i} (fun n : nat => { H : (n < length l)%nat & nth' l n H = x }).
+Proof.
+  induction l as [|a l IHl] using list_ind@{i i}.
+  1: intros x'; destruct x'.
+  intros [| i].
+  - revert a p.
+    snrapply paths_ind_r@{i i}.
+    snrefine (exist@{i i} _ 0%nat _).
+    snrefine (exist _ _ idpath).
+    apply leq_succ.
+    exact _.
+  - destruct (IHl i) as [n [H H']].
+    snrefine (exist@{i i} _ n.+1%nat _).
+    snrefine (_; _); cbn.
+    1: apply leq_succ, H.
+    refine (_ @ H').
+    apply nth'_cons.
+Defined.
+
+(** The [nth] element of a map is the function applied optionally to the [nth] element of the original list. *)
+Definition nth_list_map@{i j|} {A : Type@{i}} {B : Type@{j}}
+  (f : A -> B) (l : list A) (n : nat)
+  : nth (list_map f l) n = functor_option f (nth l n).
+Proof.
+  induction l as [|a l IHl] in n |- * using list_ind@{i j}.
+  1: by destruct n.
+  destruct n.
+  1: reflexivity.
+  apply IHl.
+Defined.
+
+(** The [nth'] element of a [list_map] is the function applied to the [nth'] element of the original list. *)
+Definition nth'_list_map@{i j|} {A : Type@{i}} {B : Type@{j}}
+  (f : A -> B) (l : list A) (n : nat) (H : (n < length l)%nat)
+  (H' : (n < length (list_map f l))%nat)
+  : nth' (list_map f l) n H' = f (nth' l n H).
+Proof.
+  induction l as [|a l IHl] in n, H, H' |- * using list_ind@{i j}.
+  1: destruct (not_lt_zero_r _ H).
+  destruct n.
+  1: reflexivity.
+  apply IHl.
+Defined.
+
+(** The [nth'] element of a [list_map2] is the function applied to the [nth'] elements of the original lists. The length of the two lists is required to be the same. *)
+Definition nth'_list_map2 {A B C : Type}
+  (f : A -> B -> C) (l1 : list A) (l2 : list B)
+  (n : nat) defl defr (H : (n < length l1)%nat) (H' : (n < length l2)%nat)
+  (H'' : (n < length (list_map2 f defl defr l1 l2))%nat)
+  (p : length l1 = length l2)
+  : f (nth' l1 n H) (nth' l2 n H') = nth' (list_map2 f defl defr l1 l2) n H''.
+Proof.
+  revert l2 n defl defr H H' H'' p;
+    simple_list_induction l1 a l1 IHl1;
+    intros l2 n defl defr H H' H'' p.
+  - destruct l2 as [|b l2].
+    + destruct (not_lt_zero_r _ H).
+    + inversion p.
+  - destruct l2 as [|b l2].
+    + inversion p.
+    + destruct n.
+      * reflexivity.
+      * erewrite 3 nth'_cons.
+        apply IHl1.
+        by apply path_nat_succ.
+Defined.
+
+(** The [nth'] element of a [repeat] is the repeated value. *)
+Definition nth'_repeat@{i|} {A : Type@{i}} (x : A) (i n : nat)
+  (H : (i < length (repeat x n))%nat)
+  : nth' (repeat x n) i H = x.
+Proof.
+  induction n as [|n IHn] in i, H |- * using nat_ind@{i}.
+  1: destruct (not_lt_zero_r _ H).
+  destruct i.
+  1: reflexivity.
+  apply IHn.
+Defined.
+
+(** Two lists are equal if their [nth'] elements are equal. *)
+Definition path_list_nth'@{i|} {A : Type@{i}} (l l' : list A)
+  (p : length l = length l')
+  : (forall n (H : (n < length l)%nat), nth' l n H = nth' l' n (p # H))
+    -> l = l'.
+Proof.
+  intros H.
+  induction l as [|a l IHl] in l', p, H |- * using list_ind@{i i}.
+  { destruct l'.
+    - reflexivity.
+    - discriminate. }
+  destruct l' as [|a' l'].
+  1: discriminate.
+  f_ap.
+  - exact (H 0%nat _).
+  - snrapply IHl.
+    1: by apply path_nat_succ.
+    intros n Hn.
+    snrefine ((nth'_cons l n a Hn _)^ @ _).
+    1: apply leq_succ, Hn.
+    lhs nrapply H.
+    nrapply nth'_cons.
+Defined.
+
+(** The [nth n] element of a concatenated list [l ++ l'] where [n < length l] is the [nth] element of [l]. *)
+Definition nth_app@{i|} {A : Type@{i}} (l l' : list A) (n : nat)
+  (H : (n < length l)%nat)
+  : nth (l ++ l') n = nth l n.
+Proof.
+  induction l as [|a l IHl] in l', n, H |- * using list_ind@{i i}.
+  1: destruct (not_lt_zero_r _ H).
+  destruct n.
+  1: reflexivity.
+  by apply IHl, leq_pred'.
+Defined.
+
+(** The [nth i] element where [pred (length l) = i] is the last element of the list. *)
+Definition nth_last {A : Type} (l : list A) (i : nat) (p : nat_pred (length l) = i)
+  : nth l i = last l. 
+Proof.
+  destruct p.
+  induction l as [|a l IHl].
+  1: reflexivity.
+  destruct l as [|b l].
+  1: reflexivity.
+  cbn; apply IHl.
+Defined.
+
+(** The last element of a list with an element appended is the appended element. *)
+Definition last_app {A : Type} (l : list A) (x : A)
+  : last (l ++ [x]) = Some x.
+Proof.
+  induction l as [|a l IHl] in x |- *.
+  1: reflexivity.
+  destruct l.
+  1: reflexivity.
+  cbn; apply IHl.
+Defined.
+
+(** ** Removing elements *)
+
+(** These functions allow surgery to be perfomed on a given list. *)
+
+(** *** Drop *)
+
+(** [drop n l] removes the first [n] elements of [l]. *)
+Fixpoint drop {A : Type} (n : nat) (l : list A) : list A :=
+  match l, n with
+  | _ :: l, n.+1%nat => drop n l
+  | _, _ => l
+  end.
+
+(** A [drop] of zero elements is the identity. *)
+Definition drop_0 {A : Type} (l : list A)
+  : drop 0 l = l.
+Proof.
+  by destruct l.
+Defined.
+
+(** A [drop] of one element is the tail of the list. *)
+Definition drop_1 {A : Type} (l : list A)
+  : drop 1 l = tail l.
+Proof.
+  induction l.
+  1: reflexivity.
+  by destruct l.
+Defined.
+
+(** A [drop] of the empty list is the empty list. *)
+Definition drop_nil {A : Type} (n : nat)
+  : drop n (@nil A) = nil.
+Proof.
+  by destruct n.
+Defined.
+
+(** A [drop] of [n] elements with [length l <= n] is the empty list. *)
+Definition drop_length_leq@{i|} {A : Type@{i}} (n : nat) (l : list A)
+  (H : (length l <= n)%nat)
+  : drop n l = nil.
+Proof.
+  induction l as [|a l IHl] in H, n |- * using list_ind@{i i}.
+  1: apply drop_nil.
+  destruct n.
+  1: destruct (not_lt_zero_r _ H).
+  cbn; apply IHl.
+  apply leq_pred'.
+  exact H.
+Defined.
+
+(** The length of a [drop n] is the length of the original list minus [n]. *)
+Definition length_drop@{i|} {A : Type@{i}} (n : nat) (l : list A)
+  : length (drop n l) = (length l - n)%nat.
+Proof.
+  induction l as [|a l IHl] in n |- * using list_ind@{i i}.
+  1: by rewrite drop_nil.
+  destruct n.
+  1: reflexivity.
+  exact (IHl n).
+Defined.
+
+(** An element of a [drop] is an element of the original list. *)
+Definition drop_inlist@{i|} {A : Type@{i}} (n : nat) (l : list A) (x : A)
+  : InList x (drop n l) -> InList x l.
+Proof.
+  intros H.
+  induction l as [|a l IHl] in n, H, x |- * using list_ind@{i i}.
+  1: rewrite drop_nil in H; contradiction.
+  destruct n.
+  1: rewrite drop_0 in H; assumption.
+  right; nrapply (IHl _ _ H).
+Defined.
+
+(** *** Take *)
+
+(** [take n l] keeps the first [n] elements of [l] and returns [l] if [n >= length l]. *)
+Fixpoint take {A : Type} (n : nat) (l : list A) : list A :=
+  match l, n with
+  | x :: l, n.+1%nat => x :: take n l
+  | _, _ => nil
+  end.
+
+(** A [take] of zero elements is the empty list. *)
+Definition take_0 {A : Type} (l : list A) : take 0 l = nil.
+Proof.
+  by destruct l.
+Defined.
+
+(** A [take] of the empty list is the empty list. *)
+Definition take_nil {A : Type} (n : nat) : take n (@nil A) = nil.
+Proof.
+  by destruct n.
+Defined.
+
+(** A [take] of [n] elements with [length l <= n] is the original list. *)
+Definition take_length_leq@{i|} {A : Type@{i}} (n : nat) (l : list A)
+  (H : (length l <= n)%nat)
+  : take n l = l.
+Proof.
+  induction l as [|a l IHl] in H, n |- * using list_ind@{i i}.
+  1: apply take_nil.
+  destruct n.
+  1: destruct (not_lt_zero_r _ H).
+  cbn; f_ap.
+  by apply IHl, leq_pred'.
+Defined.
+
+(** The length of a [take n] is the minimum of [n] and the length of the original list. *)
+Definition length_take@{i|} {A : Type@{i}} (n : nat) (l : list A)
+  : length (take n l) = nat_min n (length l).
+Proof.
+  induction l as [|a l IHl] in n |- * using list_ind@{i i}.
+  { rewrite take_nil.
+    rewrite nat_min_r.
+    1: reflexivity.
+    cbn; exact _. }
+  destruct n.
+  1: reflexivity.
+  cbn; f_ap.
+Defined.
+
+(** An element of a [take] is an element of the original list. *)
+Definition take_inlist@{i|} {A : Type@{i}} (n : nat) (l : list A) (x : A)
+  : InList x (take n l) -> InList x l.
+Proof.
+  intros H.
+  induction l as [|a l IHl] in n, H, x |- * using list_ind@{i i}.
+  1: rewrite take_nil in H; contradiction.
+  destruct n.
+  1: rewrite take_0 in H; contradiction.
+  destruct H as [-> | H].
+  - left; reflexivity.
+  - right; exact (IHl _ _ H).
+Defined.
+
+(** *** Remove *)
+
+(** [remove n l] removes the [n]-th element of [l]. *)
+Definition remove {A : Type} (n : nat) (l : list A) : list A
+  := take n l ++ drop n.+1 l.
+
+(** Removing the first element of a list is the tail of the list. *)
+Definition remove_0 {A : Type} (l : list A) : remove 0 l = tail l.
+Proof.
+  unfold remove.
+  by rewrite take_0, drop_1.
+Defined.
+
+(** Removing the [n]-th element of a list with [length l <= n] is the original list. *)
+Definition remove_length_leq {A : Type} (n : nat) (l : list A)
+  (H : (length l <= n)%nat)
+  : remove n l = l.
+Proof.
+  unfold remove.
+  rewrite take_length_leq.
+  2: exact _.
+  rewrite drop_length_leq.
+  2: exact _.
+  apply app_nil.
+Defined.
+
+(** The length of a [remove n] is the length of the original list minus one. *)
+Definition length_remove@{i|} {A : Type@{i}} (n : nat) (l : list A)
+  (H : (n < length l)%nat)
+  : length (remove n l) = nat_pred (length l)%nat.
+Proof.
+  unfold remove.
+  rewrite length_app@{i}.
+  rewrite length_take.
+  rewrite length_drop.
+  rewrite nat_min_l.
+  2: exact (leq_trans _ H).
+  rewrite <- nat_sub_l_add_r.
+  2: exact _.
+  lhs nrapply nat_sub_succ_r.
+  apply ap.
+  apply nat_add_sub_cancel_l.
+Defined. 
+
+(** An element of a [remove] is an element of the original list. *)
+Definition remove_inlist {A : Type} (n : nat) (l : list A) (x : A)
+  : InList x (remove n l) -> InList x l.
+Proof.
+  unfold remove.
+  intros p.
+  apply equiv_inlist_app in p.
+  revert p.
+  snrapply sum_rec.
+  - apply take_inlist.
+  - apply drop_inlist.
+Defined.
+
+(** *** Filter *)
+
+(** Produce the list of elements of a list that satisfy a decidable predicate. *)
+Fixpoint list_filter@{u v|} {A : Type@{u}} (l : list A) (P : A -> Type@{v})
+  (dec : forall x, Decidable (P x))
+  : list A
+  := match l with
+    | nil => nil
+    | x :: l =>
+      if dec x then x :: list_filter l P dec
+        else list_filter l P dec
+    end.
+
+Definition inlist_filter@{u v k | u <= k, v <= k} {A : Type@{u}} (l : list A)
+  (P : A -> Type@{v}) (dec : forall x, Decidable (P x)) (x : A)
+  : iff@{u k k} (InList x (list_filter l P dec)) (InList x l /\ P x).
+Proof.
+  simple_list_induction l a l IHl.
+  - simpl.
+    apply iff_inverse.
+    apply iff_equiv.
+    snrapply prod_empty_l@{v}.
+  - simpl.
+    nrapply iff_compose.
+    2: { apply iff_inverse.
+         apply iff_equiv.
+         exact (sum_distrib_r@{k k k _ _ _ k k} _ _ _). }
+    destruct (dec a) as [p|p].
+    + simpl.
+      snrapply iff_compose.
+      1: exact (sum (a = x) (prod (InList@{u} x l) (P x))).
+      1: split; apply functor_sum; only 1,3: exact idmap; apply IHl.
+      split; apply functor_sum@{k k k k}; only 2,4: apply idmap.
+      * intros [].
+        exact (idpath, p).
+      * exact fst.
+    + nrapply iff_compose.
+      1: apply IHl.
+      apply iff_inverse.
+      apply iff_equiv.
+      nrefine (equiv_compose'@{k k k} (sum_empty_l@{k} _) _).
+      snrapply equiv_functor_sum'@{k k k k k k}.
+      2: exact equiv_idmap.
+      apply equiv_to_empty.
+      by intros [[] r].
+Defined.
+
+Definition list_filter_app {A : Type} (l l' : list A) (P : A -> Type)
+  (dec : forall x, Decidable (P x))
+  : list_filter (l ++ l') P dec = list_filter l P dec ++ list_filter l' P dec.
+Proof.
+  simple_list_induction l a l IHl.
+  - reflexivity.
+  - simpl; destruct (dec a); trivial.
+    simpl; f_ap.
+Defined.
+
+(** ** Sequences *)
+
+(** The length of a reverse sequence of [n] numbers is [n]. *)
+Definition length_seq_rev@{} (n : nat)
+  : length (seq_rev n) = n.
+Proof.
+  induction n as [|n IHn].
+  1: reflexivity.
+  cbn; f_ap.
+Defined.
+
+(** The length of a sequence of [n] numbers is [n]. *)
+Definition length_seq@{} (n : nat)
+  : length (seq n) = n.
+Proof.
+  lhs nrapply length_reverse.
+  apply length_seq_rev.
+Defined.
+
+(** The reversed sequence of [n.+1] numbers is the [n] followed by the rest of the reversed sequence. *)
+Definition seq_rev_cons@{} (n : nat)
+  : seq_rev n.+1 = n :: seq_rev n.
+Proof.
+  induction n as [|n IHn].
+  1: reflexivity.
+  cbn; f_ap.
+Defined.
+
+(** The sequence of [n.+1] numbers is the sequence of [n] numbers concatenated with [[n]]. *)
+Definition seq_succ@{} (n : nat)
+  : seq n.+1 = seq n ++ [n].
+Proof.
+  apply reverse_cons.
+Defined.
+
+(** Alternate definition of [seq_rev] that keeps the proofs of the entries being [< n]. *)
+Definition seq_rev'@{} (n : nat) : list {k : nat & (k < n)%nat}.
+Proof.
+  transparent assert (f : (forall n, {k : nat & (k < n)%nat}
+    -> {k : nat & (k < n.+1)%nat})).
+  { intros m.
+    snrapply (functor_sigma idmap).
+    intros k H.
+    exact (leq_succ_r H). }
+  induction n as [|n IHn].
+  1: exact nil.
+  nrefine ((n; _) :: list_map (f n) IHn).
+  exact _.
+Defined.
+
+(** Alternate definition of [seq] that keeps the proofs of the entries being [< n]. *)
+Definition seq'@{} (n : nat) : list {k : nat & (k < n)%nat}
+  := reverse (seq_rev' n).
+
+(** The length of [seq_rev' n] is [n]. *) 
+Definition length_seq_rev'@{} (n : nat)
+  : length (seq_rev' n) = n.
+Proof.
+  induction n as [|n IHn].
+  1: reflexivity.
+  cbn; f_ap.
+  lhs nrapply length_list_map.
+  exact IHn.
+Defined.
+
+(** The length of [seq' n] is [n]. *)
+Definition length_seq'@{} (n : nat)
+  : length (seq' n) = n.
+Proof.
+  lhs nrapply length_reverse.
+  apply length_seq_rev'.
+Defined.
+
+(** The [list_map] of first projections on [seq_rev' n] is [seq_rev n]. *)
+Definition seq_rev_seq_rev'@{} (n : nat)
+  : list_map pr1 (seq_rev' n) = seq_rev n.
+Proof.
+  induction n as [|n IHn].
+  1: reflexivity.
+  simpl; f_ap.
+  lhs_V nrapply list_map_compose.
+  apply IHn.
+Defined.
+
+(** The [list_map] of first projections on [seq' n] is [seq n]. *)
+Definition seq_seq'@{} (n : nat)
+  : list_map pr1 (seq' n) = seq n.
+Proof.
+  lhs nrapply list_map_reverse_acc.
+  apply (ap reverse).
+  apply seq_rev_seq_rev'.
+Defined.
+
+(** The [nth] element of a [seq_rev] is [n - i.+1]. *)
+Definition nth_seq_rev@{} {n i} (H : (i < n)%nat)
+  : nth (seq_rev n) i = Some (n - i.+1)%nat.
+Proof.
+  induction i as [|i IHi] in n, H |- *.
+  - induction n.
+    1: destruct (not_lt_zero_r _ H).
+    cbn; by rewrite nat_sub_zero_r.
+  - induction n as [|n IHn].
+    1: destruct (not_lt_zero_r _ H).
+    by apply IHi, leq_pred'.
+Defined.
+
+(** The [nth] element of a [seq] is [i]. *)
+Definition nth_seq@{} {n i} (H : (i < n)%nat)
+  : nth (seq n) i = Some i.
+Proof.
+  induction n.
+  1: destruct (not_lt_zero_r _ H).
+  rewrite seq_succ.
+  destruct (dec (i < n)%nat) as [H'|H'].
+  - lhs nrapply nth_app.
+    1: by rewrite length_seq.
+    by apply IHn.
+  - apply geq_iff_not_lt in H'.
+    apply leq_pred' in H.
+    destruct (leq_antisym H H').
+    lhs nrapply nth_last.
+    { rewrite length_app.
+      rewrite nat_add_comm.
+      apply length_seq. }
+    nrapply last_app.
+Defined.
+
+(** The [nth'] element of a [seq'] is [i]. *)
+Definition nth'_seq'@{} (n i : nat) (H : (i < length (seq' n))%nat)
+  : (nth' (seq' n) i H).1 = i.
+Proof.
+  unshelve lhs_V nrapply nth'_list_map.
+  1: by rewrite length_list_map.
+  unshelve lhs nrapply (ap011D (fun x y => nth' x _ y) _ idpath).
+  2: apply seq_seq'.
+  apply isinj_some.
+  lhs_V nrapply nth_nth'.
+  apply nth_seq.
+  by rewrite length_seq' in H.
+Defined.
+
+Definition inlist_seq@{} (n : nat) x
+  : InList x (seq n) <~> (x < n)%nat.
+Proof.
+  simple_induction n n IHn.
+  { symmetry; apply equiv_to_empty.
+    apply not_lt_zero_r. }
+  refine (_ oE equiv_transport _ (seq_succ _)).
+  nrefine (_ oE (equiv_inlist_app _ _ _)^-1).
+  nrefine (_ oE equiv_functor_sum' (B':=x = n) IHn _).
+  2: { simpl.
+       exact (equiv_path_inverse _ _ oE sum_empty_r@{Set} _). }
+  nrefine (_ oE equiv_leq_lt_or_eq^-1).
+  rapply equiv_iff_hprop.
+Defined.
+
+(** ** Repeat *)
+
+(** The length of a repeated list is the number of repetitions. *)
+Definition length_repeat@{i|} {A : Type@{i}} (n : nat) (x : A)
+  : length (repeat x n) = n.
+Proof.
+  induction n using nat_ind@{i}.
+  - reflexivity.
+  - exact (ap S IHn).
+Defined.
+
+(** An element of a repeated list is equal to the repeated element. *)
+Definition inlist_repeat@{i|} {A : Type@{i}} (n : nat) (x y : A)
+  : InList y (repeat x n) -> y = x.
+Proof.
+  induction n as [|n IHn].
+  1:contradiction.
+  intros [p | i].
+  - by symmetry.
+  - by apply IHn.
+Defined.
+
+(** ** Forall *)
+
+(** If a predicate holds for all elements of a list, the the [for_all] predicate holds for the list. *)
+Definition for_all_inlist {A : Type} (P : A -> Type) l
+  : (forall x, InList x l -> P x) -> for_all P l.
+Proof.
+  simple_list_induction l h t IHl; intros H; cbn; trivial; split.
+  - apply H.
+    by left.
+  - apply IHl.
+    intros y i.
+    apply H.
+    by right.
+Defined.
+
+(** Conversely, if [for_all P l] then each element of the list satisfies [P]. *)
+Definition inlist_for_all {A : Type} {P : A -> Type}
+  (l : list A)
+  : for_all P l -> forall x, InList x l -> P x.
+Proof.
+  simple_list_induction l x l IHl.
+  - contradiction.
+  - intros [Hx Hl] y [-> | i].
+    + exact Hx.
+    + apply IHl.
+      1: exact Hl.
+      exact i.
+Defined.
+
+(** If a predicate [P] implies a predicate [Q] composed with a function [f], then [for_all P l] implies [for_all Q (list_map f l)]. *)
+Definition for_all_list_map {A B : Type} (P : A -> Type) (Q : B -> Type)
+  (f : A -> B) (Hf : forall x, P x -> Q (f x))
+  : forall l, for_all P l -> for_all Q (list_map f l).
+Proof.
+  simple_list_induction l x l IHl; simpl; trivial.
+  intros [Hx Hl].
+  split; auto.
+Defined.
+
+(** A variant of [for_all_map P Q f] where [Q] is [P o f]. *)
+Definition for_all_list_map' {A B : Type} (P : B -> Type) (f : A -> B)
+  : forall l, for_all (P o f) l -> for_all P (list_map f l).
+Proof.
+  by apply for_all_list_map.
+Defined.
+
+(** If a predicate [P] and a predicate [Q] together imply a predicate [R], then [for_all P l] and [for_all Q l] together imply [for_all R l]. There are also some side conditions for the default elements. *)
+Lemma for_all_list_map2 {A B C : Type}
+  (P : A -> Type) (Q : B -> Type) (R : C -> Type)
+  (f : A -> B -> C) (Hf : forall x y, P x -> Q y -> R (f x y))
+  def_l (Hdefl : forall l1, for_all P l1 -> for_all R (def_l l1))
+  def_r (Hdefr : forall l2, for_all Q l2 -> for_all R (def_r l2))
+  (l1 : list A) (l2 : list B)
+  : for_all P l1 -> for_all Q l2
+    -> for_all R (list_map2 f def_l def_r l1 l2).
+Proof.
+  revert l2;
+    simple_list_induction l1 x l1 IHl1;
+    intro l2.
+  - destruct l2 as [|y l2]; cbn; auto.
+  - simpl. destruct l2 as [|y l2]; intros [Hx Hl1];
+      [intros _ | intros [Hy Hl2] ]; simpl; auto.
+    apply Hdefl.
+    simpl; auto.
+Defined.
+
+(** A simpler variant of [for_all_map2] where both lists have the same length and the side conditions on the default elements can be avoided. *)
+Definition for_all_list_map2' {A B C : Type}
+  (P : A -> Type) (Q : B -> Type) (R : C -> Type)
+  (f : A -> B -> C) (Hf : forall x y, P x -> Q y -> R (f x y))
+  {def_l def_r} {l1 : list A} {l2 : list B}
+  (p : length l1 = length l2)
+  : for_all P l1 -> for_all Q l2
+    -> for_all R (list_map2 f def_l def_r l1 l2).
+Proof.
+  revert l2 p;
+    simple_list_induction l1 x l1 IHl1;
+    intros l2 p.
+  - destruct l2.
+    + reflexivity.
+    + discriminate.
+  - destruct l2 as [|y l2].
+    + discriminate.
+    + intros [Hx Hl1] [Hy Hl2].
+      split.
+      * by apply Hf.
+      * apply IHl1; trivial.
+        apply path_nat_succ.
+        exact p.
+Defined.
+
+(** The left fold of [f] on a list [l] for which [for_all Q l] satisfies [P] if [P] and [Q] imply [P] composed with [f]. *)
+Lemma fold_left_preserves {A B : Type}
+  (P : A -> Type) (Q : B -> Type) (f : A -> B -> A)
+  (Hf : forall x y, P x -> Q y -> P (f x y))
+  (acc : A) (Ha : P acc) (l : list B) (Hl : for_all Q l)
+  : P (fold_left f l acc).
+Proof.
+  revert acc Ha Hl;
+    simple_list_induction l x l IHl;
+    intros acc Ha Hl.
+  - exact Ha.
+  - simpl.
+    destruct Hl as [Qx Hl].
+    apply IHl; auto.
+Defined.
+
+(** [for_all] preserves the truncation predicate. *)
+Definition istrunc_for_all {A : Type}
+  {n : trunc_index} (P : A -> Type) (l : list A)
+  : for_all (fun x => IsTrunc n (P x)) l -> IsTrunc n (for_all P l).
+Proof.
+  induction l as [|x l IHl]; simpl.
+  - destruct n; exact _.
+  - intros [Hx Hl].
+    apply IHl in Hl.
+    exact _.
+Defined.
+
+Global Instance istrunc_for_all' {A : Type} {n : trunc_index}
+  (P : A -> Type) (l : list A)
+  `{forall x, IsTrunc n (P x)}
+  : IsTrunc n (for_all P l).
+Proof.
+  by apply istrunc_for_all, for_all_inlist.
+Defined.
+
+(** If a predicate holds for an element, then it holds [for_all] the elements of the repeated list. *)
+Definition for_all_repeat {A : Type} {n : nat}
+  (P : A -> Type) (x : A)
+  : P x -> for_all P (repeat x n).
+Proof.
+  intros H.
+  induction n as [|n IHn].
+  1: exact tt.
+  exact (H, IHn).
+Defined.
+
+(** We can form a list of pairs of a sigma type given a list and a for_all predicate over it. *)
+Definition list_sigma {A : Type} (P : A -> Type) (l : list A) (p : for_all P l)
+  : list {x : A & P x}.
+Proof.
+  induction l as [|x l IHl] in p |- *.
+  1: exact nil.
+  destruct p as [Hx Hl].
+  exact ((x; Hx) :: IHl Hl).
+Defined.
+
+(** The length of a list of sigma types is the same as the original list. *)
+Definition length_list_sigma {A : Type} {P : A -> Type} {l : list A} {p : for_all P l}
+  : length (list_sigma P l p) = length l.
+Proof.
+  revert p; simple_list_induction l x l IHl; intro p.
+  1: reflexivity.
+  destruct p as [Hx Hl].
+  cbn; f_ap.
+  apply IHl.
+Defined.
+
+(** If a predicate [P] is decidable then so is [for_all P]. *)
+Global Instance decidable_for_all {A : Type} (P : A -> Type)
+  `{forall x, Decidable (P x)} (l : list A)
+  : Decidable (for_all P l).
+Proof.
+  simple_list_induction l x l IHl; exact _.
+Defined.
+
+(** If a predicate [P] is decidable then so is [list_exists P]. *)
+Global Instance decidable_list_exists {A : Type} (P : A -> Type)
+  `{forall x, Decidable (P x)} (l : list A)
+  : Decidable (list_exists P l).
+Proof.
+  simple_list_induction l x l IHl; exact _.
+Defined.
+
+Definition inlist_list_exists {A : Type} (P : A -> Type) (l : list A)
+  : list_exists P l -> exists (x : A), InList x l /\ P x.
+Proof.
+  simple_list_induction l x l IHl.
+  1: done.
+  simpl.
+  intros [Px | ex].
+  - exists x.
+    by split; [left|].
+  - destruct (IHl ex) as [x' [H Px']].
+    exists x'.
+    by split; [right|].
+Defined.
+
+Definition list_exists_inlist {A : Type} (P : A -> Type) (l : list A)
+  : forall (x : A), InList x l -> P x -> list_exists P l.
+Proof.
+  simple_list_induction l x l IHl.
+  1: trivial.
+  simpl; intros y H p; revert H.
+  apply functor_sum.
+  - exact (fun r => r^ # p).
+  - intros H.
+    by apply (IHl y).
+Defined.
+
+Definition list_exists_seq {n : nat} (P : nat -> Type)
+  (H : forall k, P k -> (k < n)%nat)
+  : (exists k, P k) <-> list_exists P (seq n).
+Proof.
+  split.
+  - intros [k p].
+    snrapply (list_exists_inlist P _ k _ p).
+    apply inlist_seq, H.
+    exact p.
+  - intros H1.
+    apply inlist_list_exists in H1.
+    destruct H1 as [k [Hk p]].
+    exists k.
+    exact p.
+Defined.
+
+(** An upper bound on witnesses of a decidable predicate makes the sigma type decidable. *)
+Definition decidable_exists_nat (n : nat) (P : nat -> Type)
+  (H1 : forall k, P k -> (k < n)%nat)
+  (H2 : forall k, Decidable (P k))
+  : Decidable (exists k, P k).
+Proof.
+  nrapply decidable_iff.
+  1: apply iff_inverse; nrapply list_exists_seq.
+  1: exact H1.
+  exact _.
+Defined.
diff --git a/theories/Spaces/Nat.v b/theories/Spaces/Nat.v
index 5672ee9eac3..9141d9b2cce 100644
--- a/theories/Spaces/Nat.v
+++ b/theories/Spaces/Nat.v
@@ -1,2 +1,5 @@
+(** Nat.Paths has many dependencies, so if you do not need it, it is better to explicitly require only those files that you need. *)
+
 Require Export Nat.Core.
 Require Export Nat.Arithmetic.
+Require Export Nat.Paths.
diff --git a/theories/Spaces/Nat/Arithmetic.v b/theories/Spaces/Nat/Arithmetic.v
index 8ee89b24a98..a117f5a388a 100644
--- a/theories/Spaces/Nat/Arithmetic.v
+++ b/theories/Spaces/Nat/Arithmetic.v
@@ -6,791 +6,168 @@ Local Set Universe Minimization ToSet.
 Local Close Scope trunc_scope.
 Local Open Scope nat_scope.
 
-Ltac nat_absurd_trivial :=
-  unfold ">" in *; unfold "<" in *;
-  match goal with
-  | [ H : ?n.+1 <= 0 |- _ ] => contradiction (not_leq_Sn_0 n H)
-  | [ H : ?n.+1 <= ?n |- _ ] => contradiction (not_lt_n_n n H)
-  | [ H1 : ?k.+1 <= ?n |- _ ] =>
-      match goal with
-      | [ H2 : ?n <= ?k |- _] =>
-          contradiction (not_leq_Sn_n k (@leq_trans _ _ _ H1 H2))
-      end
-  end.
-
-#[export] Hint Resolve not_lt_n_n : nat.
-#[export] Hint Resolve not_lt_n_0 : nat.
-#[export] Hint Resolve not_leq_Sn_0 : nat.
-#[export] Hint Extern 2 => nat_absurd_trivial : nat.
-
-(** This is defined so that it can be added to the [nat] auto hint database. *)
-Local Definition symmetric_paths_nat (n m : nat)
-  : n = m -> m = n := @symmetric_paths nat n m.
-
-Local Definition transitive_paths_nat (n m k : nat)
-  : n = m -> m = k -> n = k := @transitive_paths nat n m k.
-
-#[export] Hint Resolve symmetric_paths_nat | 5 : nat.
-#[export] Hint Resolve transitive_paths_nat : nat.
-#[export] Hint Resolve leq_0_n : nat.
-#[export] Hint Resolve leq_trans : nat.
-#[export] Hint Resolve leq_antisym : nat.
-
-Proposition assoc_nat_add (n m k : nat)
-  : n + (m + k) = (n + m) + k.
-Proof.
-  revert m k; simple_induction n n IHn.
-  - reflexivity.
-  - intros m k. change (n.+1 + (m + k)) with (n + (m + k)).+1.
-    apply (transitive_paths _ _ _ (nat_add_n_Sm _ _)).
-    change (m + k).+1 with (m.+1 + k);
-    change (n.+1 + m) with (n + m).+1.
-    apply (transitive_paths _ _ _ (IHn m.+1 k)).
-    apply (ap (fun zz => zz + k)).
-    apply symmetric_paths, nat_add_n_Sm. 
-Defined.
-
-Proposition not_lt_implies_geq {n m : nat} : ~(n < m) -> m <= n.
-Proof.
-  intros not_lt.
-  destruct (@leq_dichot m n); [ assumption | contradiction].
-Defined.
-
-Proposition not_leq_implies_gt {n m : nat} : ~(n <= m) -> m < n.
-Proof.
-  intros not_leq. 
-  destruct (@leq_dichot n m); [ contradiction | assumption].
-Defined.
-
-Proposition lt_implies_not_geq {n m : nat} : (n < m) -> ~(m <= n).
-Proof.
-  intros ineq1 ineq2.
-  contradiction (not_lt_n_n n). by apply (leq_trans ineq1).
-Defined.
-
-Proposition leq_implies_not_gt {n m : nat} : (n <= m) -> ~(m < n).
-Proof.
-  intros ineq1 ineq2.
-  contradiction (not_lt_n_n n); by refine (leq_trans _ ineq2).
-Defined.
-
-Ltac convert_to_positive :=
-  match goal with
-  | [ H : ~ (?n < ?m) |- _] =>  apply not_lt_implies_geq in H
-  | [ H : ~ (?n <= ?m) |- _] => apply not_leq_implies_gt in H
-  | [|- ~ (?n < ?m) ] => apply leq_implies_not_gt
-  | [|- ~ (?n <= ?m) ] => apply lt_implies_not_geq
-  end.
-
-#[export] Hint Extern 2 => convert_to_positive : nat.
-
-(** Because of the inductive definition of [<=], one can destruct the proof of [n <= m] and get a judgemental identification between [n] and [m] rather than a propositional one, which may be preferable to the following lemma. *)
-Proposition leq_split {n m : nat} : (n <= m) -> sum (n < m) (n = m).
-Proof.
-  intro l. induction l.
-  - now right.
-  - left. exact (leq_S_n' _ _ l).
-Defined.
-
-Proposition diseq_implies_lt (n m : nat)
-  : n <> m -> sum (n < m) (n > m).
-Proof.
-  intros diseq.
-  destruct (dec (n < m)) as [| a]; [ now left |].
-  right. destruct (@leq_dichot n m) as [n_leq_m | gt];
-    [ | assumption].
-  destruct n_leq_m;
-    [ now contradiction diseq
-    | contradiction a; now apply leq_S_n'].
-Defined.
-
-Proposition lt_implies_diseq (n m : nat)
-  : n < m -> (n <> m).
-Proof.
-  intros ineq eq. rewrite eq in ineq.
-  contradiction (not_lt_n_n m).
-Defined.
-
-#[export] Hint Resolve lt_implies_diseq : nat.
-
-(** This lemma is just for convenience in the case where the user forgets to unfold the definition of [<]. *)
-Proposition n_lt_Sn (n : nat) : n < n.+1.
-Proof.
-  exact (leq_n n.+1).
-Defined.
-
-Proposition leq_S' (n m : nat) : n.+1 <= m -> n <= m.
-Proof.
-  intro l.
-  now apply leq_S_n, leq_S.
-Defined.
-
-Ltac easy_eq_to_ineq :=
-  match goal with
-  | [ H : ?x = ?n    |- ?x <= ?n ] => destruct H; constructor
-  | [ H : ?x.+1 = ?n |- ?x <= ?n ] => rewrite <- H; constructor;
-                                      constructor
-  | [ H : ?x.+1 = ?n |- ?x < ?n  ] => rewrite <- H; apply leq_n
-  | [ H : ?x.+2 = ?n |- ?x <= ?n ] => rewrite <- H; apply leq_S';
-                                      apply leq_S'; apply leq_n
-  | [ H : ?x.+2 = ?n |- ?x < ?n ] => rewrite <- H; apply leq_S_n';
-                                      apply leq_S
-  end.
-
-#[export] Hint Extern 3 => easy_eq_to_ineq : nat.
-  
-Proposition mixed_trans1 (n m k : nat)
-  : n <= m -> m < k -> n < k.
-Proof.
-  intros l j. apply leq_S_n' in l.
-  apply (@leq_trans (n.+1) (m.+1) k); trivial. 
-Defined.
-
-Ltac leq_trans_resolve :=
-  match goal with
-  | [ H : ?n <= ?m |- ?n <= ?k ] => apply (leq_trans H)
-  | [ H : ?k <= ?m |- ?n <= ?k ] => refine (leq_trans _ H)
-  | [ H : ?n <= ?m |- ?n < ?k ] => apply (mixed_trans1 _ _ _ H)
-  | [ H : ?m <= ?k |- ?n < ?k ] => refine (leq_trans _ H)
-  | [ H : ?m <  ?k |- ?n < ?k ] => refine (mixed_trans1 _ _ _ _ H)
-  | [ H : ?n <  ?m |- ?n < ?k ] => apply (leq_trans H)
-  end.
-
-#[export] Hint Extern 2 => leq_trans_resolve : nat.
-
-Proposition mixed_trans2 (n m k : nat)
-  : n < m -> m <= k -> n < k.
-Proof.
-  intros l j. apply (@leq_trans (n.+1) m k); trivial. 
-Defined.
-
-#[export] Hint Resolve mixed_trans1 : nat.
-#[export] Hint Resolve mixed_trans2 : nat.
-
-Proposition sub_n_n (n : nat) : n - n = 0.
-Proof.
-  simple_induction n n IHn.
-  - reflexivity.
-  - simpl; exact IHn.
-Defined.
-
-Proposition sub_n_0 (n : nat) : n - 0 = n.
-Proof.
- destruct n; reflexivity.
-Defined.
-
-Ltac rewrite_subn0 :=
-  match goal with
-  | [ |- context [ ?n - 0 ] ] => rewrite -> sub_n_0
-  end.
-
-Ltac rewrite_subnn :=
-  match goal with
-  | [ |- context [ ?n - ?n ] ] => rewrite -> sub_n_n
-  end.
-
-#[export] Hint Rewrite -> sub_n_0 : nat.
-#[export] Hint Rewrite -> sub_n_n : nat.
-#[export] Hint Resolve sub_n_0 : nat.
-
-Proposition add_n_sub_n_eq (m n : nat) : m + n - n = m.
-Proof.
-  destruct m.
-  - simple_induction' n.
-    + reflexivity.
-    + assumption.
-  - simple_induction' n.
-    + simpl. destruct (add_n_O m); reflexivity.
-    + simpl. destruct (add_n_Sm m n). assumption.
-Defined.
-
-Proposition add_n_sub_n_eq' (m n : nat) : n + m - n = m.
-Proof. 
-  destruct (nat_add_comm m n). exact (add_n_sub_n_eq m n).
-Defined.
- 
-Proposition n_lt_m_n_leq_m { n m : nat } : n < m -> n <= m.
-Proof.
-  intro H. apply leq_S, leq_S_n in H; exact H.
-Defined.
-
-#[export] Hint Resolve n_lt_m_n_leq_m : nat.
-
-Proposition lt_trans (n m k : nat) : n < m -> m < k -> n < k.
-Proof.
-  eauto with nat.
-Defined.
-
-Proposition not_both_less (n m : nat) : n < m -> ~(m < n).
-Proof.
-  intros l a; contradiction (not_lt_n_n _ (lt_trans _ _ _ l a)).
-Defined.  
-
-Proposition n_leq_add_n_k (n m : nat) : n <= n + m.
-Proof.
-  simple_induction n n IHn.
-  - apply leq_0_n.
-  - simpl; apply leq_S_n', IHn.
-Defined.
-
-Proposition n_leq_add_n_k' (n m : nat) : n <= m + n.
-Proof.
-  simple_induction' m.
-  - exact(leq_n n).
-  - simpl. apply leq_S. assumption.
-Defined.
-
-Proposition natineq0eq0 {n : nat} : n <= 0 -> n = 0.
-Proof.
-  destruct n.
-  - reflexivity.
-  - intro. contradiction (not_leq_Sn_0 n).
-Defined.
-
-Proposition subsubadd (n m k : nat) : n - (m + k) = n - m - k.
-Proof.
-  revert m k; simple_induction n n IHn.
-  - reflexivity.
-  - intro m; destruct m; intro k.
-    + change (0 + k) with k; reflexivity.
-    + change (m.+1 + k) with (m + k).+1; apply IHn.
-Defined.
-
-#[export] Hint Resolve subsubadd : nat.
-
-Proposition subsubadd' (n m k : nat) : n - m - k = n - (m + k).
-Proof.
-  auto with nat.
-Defined.
-
-Definition nleqSm_dichot {n m : nat}
-  : (n <= m.+1) -> sum (n <= m) (n = m.+1).
-Proof.
-  revert m; simple_induction n n IHn.
-  - intro. left. exact (leq_0_n m).
-  - destruct m.
-    + intro l. apply leq_S_n, natineq0eq0 in l.
-      right; apply ap; exact l.
-    + intro l. apply leq_S_n, IHn in l; destruct l as [a | b].
-      * left. apply leq_S_n'; exact a.
-      * right. apply ap; exact b.
-Defined.
-
-Proposition sub_leq_0 (n m : nat) : n <= m -> n - m = 0.
-Proof.
-  intro l; induction l.
-  - exact (sub_n_n n).
-  - change (m.+1) with (1 + m). destruct n.
-    + reflexivity.
-    + destruct (nat_add_comm m 1).
-      destruct (symmetric_paths _ _ (subsubadd n.+1 m 1)).
-      destruct (symmetric_paths _ _ IHl).
-      reflexivity.
-Defined.
-
-Proposition sub_leq_0_converse (n m : nat) : n - m = 0 -> n <= m.
-Proof.
-  revert m; simple_induction n n IHn.
-  - auto with nat.
-  - intros m eq. destruct m.
-    + simpl in eq. apply symmetric_paths in eq.
-      contradiction (not_eq_O_S n eq).
-    + simpl in eq. apply leq_S_n', IHn, eq.
-Defined.
-
-Proposition sub_gt_0_lt (n m : nat) : n - m > 0 -> m < n.
-Proof.
-  intro ineq.
-  destruct (@leq_dichot n m) as [n_leq_m |]; [ | assumption].
-  apply sub_leq_0 in n_leq_m.
-  contradiction (not_lt_n_n 0). now rewrite n_leq_m in ineq.
-Defined.
-
-Proposition lt_sub_gt_0 (n m : nat) : m < n -> 0 < n - m.
-Proof.
-  revert m; simple_induction n n IHn.
-  - intros m ineq. contradiction (not_lt_n_0 m).
-  - destruct m.
-    + simpl. easy.
-    + simpl. intro ineq. apply leq_S_n in ineq.
-      now apply IHn in ineq.
-Defined.
-
-Proposition natminuspluseq (n m : nat)
-  : n <= m -> (m - n) + n = m.
-Proof.
-  revert m; simple_induction n n IHn.
-  - intros. destruct m; [reflexivity |]. simpl.
-    apply (ap S), symmetric_paths, add_n_O.
-  - intros m l. destruct m.
-    + contradiction (not_leq_Sn_0 n).
-    + simpl. apply leq_S_n, IHn in l.
-      destruct (nat_add_n_Sm (m - n) n).
-      destruct (symmetric_paths _ _ l).
-      reflexivity.
-Defined.
-
-Proposition natminusplusineq (n m : nat) : n <= n - m + m.
-Proof.
-  destruct (@leq_dichot m n) as [l | g].
-  - destruct (symmetric_paths _ _ (natminuspluseq _ _ l));
-      constructor.
-  - apply n_lt_m_n_leq_m in g.
-    now destruct (symmetric_paths _ _ (sub_leq_0 n m _)).
-Defined.
-
-Proposition natminuspluseq' (n m : nat)
-  : n <= m -> n + (m - n) = m.
-Proof.
-  intros. destruct (symmetric_paths _ _ (nat_add_comm n (m - n))).
-  apply natminuspluseq. assumption.
-Defined.
-
-#[export] Hint Rewrite -> natminuspluseq : nat.
-#[export] Hint Rewrite -> natminuspluseq' : nat.
-
-#[export] Hint Resolve leq_S_n' : nat.
-
-Ltac leq_S_n_in_hypotheses :=
-  match goal with
-  | [ H : ?n.+1 <= ?m.+1 |- _ ] => apply leq_S_n in H
-  | [ H : ?n < ?m.+1 |- _ ] => apply leq_S_n in H
-  | [ H : ?m.+1 > ?n |- _ ] => apply leq_S_n in H
-  | [ H : ?m.+1 >= ?n.+1 |- _ ] => apply leq_S_n in H
-  end.
-
-#[export] Hint Extern 4 => leq_S_n_in_hypotheses : nat.
-                                                     
-Proposition nataddpreservesleq { n m k : nat }
-  : n <= m -> n + k <= m + k.
-Proof.
-  intro l.
-  simple_induction k k IHk.
-  - destruct (add_n_O n), (add_n_O m); exact l.
-  - destruct (nat_add_n_Sm n k), (nat_add_n_Sm m k);
-      apply leq_S_n'; exact IHk.
-Defined.
-
-#[export] Hint Resolve nataddpreservesleq : nat.
-
-Proposition nataddpreservesleq' { n m k : nat }
-  : n <= m -> k + n <= k + m.
-Proof.
-  destruct (symmetric_paths _ _ (nat_add_comm k m)),
-    (symmetric_paths _ _ (nat_add_comm k n)).
-  exact nataddpreservesleq.
-Defined.
-
-#[export] Hint Resolve nataddpreservesleq' : nat.
-
-Proposition nataddpreserveslt { n m k : nat }
-  : n < m -> n + k < m + k.
-Proof.
-  unfold "<".
-  change (n + k).+1 with (n.+1 + k).
-  generalize (n.+1). intros n' l.
-  simple_induction k k IHk.
-  - destruct (add_n_O n'), (add_n_O m); exact l.
-  - destruct (nat_add_n_Sm n' k), (nat_add_n_Sm m k);
-      apply leq_S_n'; exact IHk.
-Defined.
-
-Proposition nataddpreserveslt' { n m k : nat }
-  : n < m -> k + n < k + m.
-Proof.
-  destruct (symmetric_paths _ _ (nat_add_comm k n)),
-    (symmetric_paths _ _ (nat_add_comm k m));
-    exact nataddpreserveslt.
-Defined.
-
-Proposition nataddreflectslt { n m k : nat }
-  : n + k < m + k -> n < m.
-Proof.
-  simple_induction k k IHk.
-  - destruct (add_n_O n), (add_n_O m); trivial.
-  - intro l. destruct (nat_add_n_Sm n k), (nat_add_n_Sm m k) in l.
-    apply leq_S_n, IHk in l; exact l.
-Defined.
-
-Proposition nataddreflectsleq { n m k : nat }
-  : n + k <= m + k -> n <= m.
-Proof.
-  destruct n.
-  - intros ?; apply leq_0_n.
-  - intro a. change (n.+1 + k) with (n + k).+1 in a.
-    now apply (@nataddreflectslt n m k).
-Defined.
-
-Proposition nataddreflectslt' { n m k : nat }
-  : k + n < k + m -> n < m.
-Proof.
-  destruct (symmetric_paths _ _ (nat_add_comm k n)),
-    (symmetric_paths _ _ (nat_add_comm k m));
-    exact nataddreflectslt.
-Defined.
-
-Proposition nataddreflectsleq' { n m k : nat }
-  : k + n <= k + m -> n <= m.
-Proof.
-  destruct (symmetric_paths _ _ (nat_add_comm k n)),
-    (symmetric_paths _ _ (nat_add_comm k m));
-    exact nataddreflectsleq.
-Defined.
-
-Proposition natsubreflectsleq { n m k : nat }
-  : k <= m -> n - k <= m - k -> n <= m.
-Proof.
-  intros ineq1 ineq2.
-  apply (@nataddpreservesleq _ _ k) in ineq2.
-  apply (@leq_trans _ (n - k + k) _ (natminusplusineq _ _)).
-  apply (@leq_trans _ (m - k + k)  _ _).
-  destruct (symmetric_paths _ _ (natminuspluseq k m ineq1)); easy.
-Defined.
-
-Proposition nataddsub_assoc_lemma {k m : nat}
-  : (k <= m) -> m.+1 - k = (m - k).+1.
-Proof.
-  revert m; simple_induction k k IHk.
-  - intros m l; simpl. destruct m; reflexivity.
-  - destruct m.
-    + simpl; intro g; contradiction (not_leq_Sn_0 _ g).
-    + intro l; apply leq_S_n in l.
-      change (m.+2 - k.+1) with (m.+1 - k).
-      change (m.+1 - k.+1) with (m - k).
-      exact (IHk _ l).
-Defined.
-
-Proposition nataddsub_assoc (n : nat) {m k : nat}
-  : (k <= m) -> n + (m - k) = n + m - k.
-Proof.
-  revert m k. simple_induction n n IHn.
-  - reflexivity.
-  - intros m k l.
-    change (n.+1 + (m - k)) with (n + (m - k)).+1;
-      change (n.+1 + m) with (n +m).+1.
-    destruct k, m;
-      [ reflexivity
-      | reflexivity
-      | contradiction (not_lt_n_0 k _)
-      | ].
-    simpl "-". apply leq_S_n in l.
-    destruct (symmetric_paths _ _ (nat_add_n_Sm n (m - k))).
-    destruct  (nataddsub_assoc_lemma l).
-    apply (IHn m.+1 k).
-    apply leq_S.
-    assumption.
-Defined.
-
-Proposition nataddsub_comm (n m k : nat)
-  : m <= n -> (n - m) + k = (n + k) - m.
-Proof.
-  intro l.
-  destruct (nat_add_comm k n).
-  destruct (nataddsub_assoc k l).
-  apply nat_add_comm.
-Defined.
+(** TODO: The results in this file are in the process of being moved over to Core.v *)
 
+(** TODO: move, rename *)
 Proposition nataddsub_comm_ineq_lemma (n m : nat)
   : n.+1 - m <= (n - m).+1.
 Proof.
   revert m.
   simple_induction n n IHn.
-  - simple_induction m m IHm; [ apply leq_n | apply leq_S; apply leq_n ]. 
+  - simple_induction m m IHm; exact _. 
   - intro m; simple_induction m m IHm.
-    + apply leq_n.
+    + apply leq_refl.
     + apply IHn.
 Defined.
 
+(** TODO: move, rename *)
 Proposition nataddsub_comm_ineq (n m k : nat)
   : (n + k) - m <= (n - m) + k.
-Proof. 
+Proof.
   simple_induction k k IHk.
-  - destruct (add_n_O n), (add_n_O (n - m)); constructor.
-  - destruct (add_n_Sm n k).
+  - destruct (nat_add_zero_r n)^, (nat_add_zero_r (n - m))^; constructor.
+  - destruct (nat_add_succ_r n k)^.
     refine (leq_trans (nataddsub_comm_ineq_lemma (n+k) m) _).
-    destruct (add_n_Sm (n - m) k).
-    now apply leq_S_n'.
+    destruct (nat_add_succ_r (n - m) k)^.
+    now apply leq_succ.
 Defined.
 
+(** TODO: move, rename *)
 Proposition nat_sub_add_ineq (n m : nat) : n <= n - m + m.
 Proof.
-  destruct (@leq_dichot m n) as [l | gt].
-  - destruct (symmetric_paths _ _ (nataddsub_comm _ _ m l)).
-    destruct (symmetric_paths _ _ (add_n_sub_n_eq n m)).
+  destruct (@leq_dichotomy m n) as [l | gt].
+  - rewrite <- nat_sub_l_add_l; trivial.
+    destruct (nat_add_sub_cancel_r n m)^.
     apply leq_refl; done.
-  - apply n_lt_m_n_leq_m in gt.
-    destruct (symmetric_paths _ _ (sub_leq_0 n m _)).
+  - apply leq_lt in gt.
+    destruct (equiv_nat_sub_leq _)^.
     assumption.
 Defined.
 
+(** TODO: move, rename *)
 Proposition i_lt_n_sum_m (n m i : nat)
   : i < n - m -> m <= n.
 Proof.
   revert m i; simple_induction n n IHn.
-  - intros m i l. simpl in l. contradiction (not_lt_n_0 _ _).
+  - intros m i l. simpl in l. contradiction (not_lt_zero_r _ _).
   - intros m i l. destruct m.
-    + apply leq_0_n.
-    + apply leq_S_n'. simpl in l. apply (IHn m i l).
-Defined.
-  
-Proposition nataddsub_assoc_implication (n : nat) {m k z : nat}
-  : (k <= m) -> n + (m - k) = z -> n + m - k = z.
-Proof.
-  intro H.
-  destruct (symmetric_paths _ _ (nataddsub_assoc n H)); done.
+    + apply leq_zero_l.
+    + apply leq_succ. simpl in l. apply (IHn m i l).
 Defined.
 
-#[export] Hint Resolve nataddsub_assoc_implication : nat.
-
-Proposition nat_add_sub_eq (n : nat) {k: nat}
-  : (k <= n) -> k + (n - k) = n.
-Proof.
-  intro H.
-  destruct (symmetric_paths _ _ (nataddsub_assoc k H));
-  destruct (nat_add_comm n k); exact (add_n_sub_n_eq _ _).
-Defined.
-
-#[export] Hint Resolve nat_add_sub_eq : nat.
-
-Proposition predeqminus1 { n : nat } : n - 1 = pred n.
+(** TODO: move, rename *)
+Proposition predeqminus1 { n : nat } : n - 1 = nat_pred n.
 Proof.
   simple_induction' n.
   - reflexivity.
-  - apply sub_n_0.
+  - apply nat_sub_zero_r.
 Defined.
 
-Proposition predn_leq_n (n : nat) : pred n <= n.
+(** TODO: move, rename *)
+Proposition predn_leq_n (n : nat) : nat_pred n <= n.
 Proof.
-  case n; [ apply leq_n | intro; apply leq_S; apply leq_n].
+  destruct n; exact _.
 Defined.
 
-#[export] Hint Resolve predn_leq_n : nat.
-
-Proposition S_predn (n i: nat) : (i < n) -> S(pred n) = n.
-Proof.
-  simple_induction' n; intros l.
-  - contradiction (not_lt_n_0 i).
-  - reflexivity.
-Defined.
-
-#[export] Hint Rewrite S_predn : nat.
-#[export] Hint Rewrite <- pred_Sn : nat.
-
-#[export] Hint Resolve S_predn : nat.
-#[export] Hint Resolve leq_n_pred : nat.
-
-Proposition pred_equiv (k n : nat) : k < n -> k < S (pred n).
+(** TODO: move, rename *)
+Proposition pred_equiv (k n : nat) : k < n -> k < S (nat_pred n).
 Proof. 
   intro ineq; destruct n.
-  - contradiction (not_lt_n_0 _ _).
+  - contradiction (not_lt_zero_r _ _).
   - assumption.
 Defined.
 
-Proposition n_leq_pred_Sn (n : nat) : n <= S (pred n).
+(** TODO: move, rename *)
+Proposition n_leq_pred_Sn (n : nat) : n <= S (nat_pred n).
 Proof. 
-  destruct n; auto.
+  destruct n; exact _.
 Defined.
 
+(** TODO: move, rename *)
 Proposition leq_implies_pred_lt (i n k : nat)
-  : (n > i) -> n <= k -> pred n < k.
+  : (n > i) -> n <= k -> nat_pred n < k.
 Proof.
   intro ineq; destruct n.
-  - contradiction (not_lt_n_0 i).
+  - contradiction (not_lt_zero_r i).
   - intro; assumption.
 Defined.
   
+(** TODO: move, rename *)
 Proposition pred_lt_implies_leq (n k : nat)
-  : pred n < k -> n <= k.
+  : nat_pred n < k -> n <= k.
 Proof.
   intro l; destruct n.
-  - apply leq_0_n.
+  - apply leq_zero_l.
   - assumption.
 Defined.
 
-Proposition lt_implies_pred_geq (i j : nat) : i < j -> i <= pred j.
+(** TODO: move, rename *)
+Proposition lt_implies_pred_geq (i j : nat) : i < j -> i <= nat_pred j.
 Proof.
-  intro l; apply leq_n_pred in l; assumption.
+  intro l; apply leq_pred in l; assumption.
 Defined.
 
-#[export] Hint Resolve lt_implies_pred_geq : nat.
-
+(** TODO: move, rename *)
 Proposition j_geq_0_lt_implies_pred_geq (i j k : nat)
-  : i < j -> k.+1 <= j -> k <= pred j.
+  : i < j -> k.+1 <= j -> k <= nat_pred j.
 Proof.
   intros l ineq.
   destruct j.
-  - contradiction (not_lt_n_0 i).
-  - now simpl; apply leq_S_n.
+  - contradiction (not_lt_zero_r i).
+  - now simpl; apply leq_pred'.
 Defined.
 
-#[export] Hint Resolve lt_implies_pred_geq : nat.
-
+(** TODO: move, rename *)
 Proposition pred_gt_implies_lt (i j : nat)
-  : i < pred j -> i.+1 < j.
+  : i < nat_pred j -> i.+1 < j.
 Proof.
   intros ineq.
-  assert (H := leq_S_n' _ _ ineq). assert (i < j) as X. {
-    apply (@mixed_trans2 _ (pred j) _);
+  assert (H := leq_succ ineq). assert (i < j) as X. {
+    apply (@lt_lt_leq_trans _ (nat_pred j) _);
       [assumption  | apply predn_leq_n].
   }
-  destruct (symmetric_paths _ _ (S_predn _ _ X)) in H.
-  assumption.
+  by rewrite <- (nat_succ_pred' j i).
 Defined.
 
+(** TODO: move, rename *)
 Proposition pred_preserves_lt {i n: nat} (p : i < n) m
-  : (n < m) -> (pred n < pred m).
+  : (n < m) -> (nat_pred n < nat_pred m).
 Proof.
   intro l.
-  apply leq_S_n. destruct (symmetric_paths _ _ (S_predn n i _)).
+  apply leq_pred'. destruct (symmetric_paths _ _ (nat_succ_pred' n i _)).
   set (k :=  transitive_lt i n m p l).
-  destruct (symmetric_paths _ _ (S_predn m i _)).
+  destruct (symmetric_paths _ _ (nat_succ_pred' m i _)).
   assumption.
 Defined.
 
-Proposition natsubpreservesleq { n m k : nat }
-  : n <= m -> n - k <= m - k.
-Proof.
-  simple_induction k k IHk.
-  - destruct (symmetric_paths _ _ (sub_n_0 n)),
-      (symmetric_paths _ _ (sub_n_0 m)); done.
-  - intro l. change (k.+1) with (1 + k).
-    destruct (nat_add_comm k 1).
-    destruct (symmetric_paths _ _ (subsubadd n k 1)).
-    destruct (symmetric_paths _ _ (subsubadd m k 1)).
-    destruct (symmetric_paths _ _ (@predeqminus1 (n -k))).
-    destruct (symmetric_paths _ _ (@predeqminus1 (m -k))).
-    apply leq_n_pred, IHk. exact l.
-Defined.
-
-#[export] Hint Resolve natsubpreservesleq : nat.
-
+(** TODO: move, rename *)
 Proposition sub_less { n k : nat } : n - k <= n.
 Proof.
   revert k.
   simple_induction n n IHn.
-  - intros; apply leq_0_n.
+  - intros; apply leq_zero_l.
   - destruct k.
-    + apply leq_n.
+    + apply leq_refl.
     + simpl; apply (@leq_trans _ n _);
-        [ apply IHn | apply leq_S, leq_n].
+        [ apply IHn | apply leq_succ_r, leq_refl].
 Defined.
 
-#[export] Hint Resolve sub_less : nat.
-#[export] Hint Resolve leq_S_n' : nat.
-
+(** TODO: move, rename *)
 Proposition sub_less_strict { n k : nat }
   : 0 < n -> 0 < k -> n - k < n.
 Proof.
   intros l l'.
   unfold "<".
   destruct k, n;
-  try (contradiction (not_lt_n_0 _ _)).
-  simpl; apply leq_S_n', sub_less.
-Defined.
-
-Proposition natpmswap1 (k m n : nat)
-  : n <= k -> k < n + m -> k - n < m.
-Proof.
-  intros l q.
-  assert (q' : k - n + n < m + n) by
-    (destruct (symmetric_paths _ _ (natminuspluseq n k l));
-     destruct (nat_add_comm n m);
-     assumption).
-  exact (nataddreflectslt q').
-Defined.
-
-#[export] Hint Resolve natpmswap1 : nat.
-
-Proposition natpmswap2 (k m n : nat)
-  : n <= k -> k - n <= m -> k <= n + m.
-Proof.
-  intros l q.
-  apply (@nataddpreservesleq' (k - n) m n) in q.
-  destruct (symmetric_paths _ _ (nataddsub_assoc n l)) in q.
-  destruct (symmetric_paths _ _ (add_n_sub_n_eq' k n)) in q;
-    assumption.
-Defined.
-
-#[export] Hint Resolve natpmswap2 : nat.
-
-Proposition natpmswap3 (k m n : nat)
-  : k <= n -> m <= n - k -> k + m <= n.
-Proof.
-  intros ineq qe.
-  apply (@nataddpreservesleq' m (n - k) k) in qe.
-  destruct (symmetric_paths _ _ (nataddsub_assoc k ineq)) in qe.
-  destruct (symmetric_paths _ _ (add_n_sub_n_eq' n k)) in qe;
-    assumption.
-Defined.
-
-#[export] Hint Resolve natpmswap3 : nat.
-
-Proposition natpmswap4 (k m n : nat)
-  : k - n < m -> k < n + m.
-Proof.
-  intro l; apply (@nataddpreserveslt (k - n) m n) in l.
-  destruct (nat_add_comm m n).
-  now apply (mixed_trans1 k (k - n + n) (m + n)
-               (nat_sub_add_ineq _ _)).
+  try (contradiction (not_lt_zero_r _ _)).
+  simpl; apply leq_succ, sub_less.
 Defined.
 
-#[export] Hint Resolve natpmswap4 : nat.
-
+(** TODO: move, rename *)
 Proposition n_leq_m_n_leq_plus_m_k (n m k : nat)
   : n <= m -> n <= m + k.
 Proof.
-  intro l; apply (leq_trans l); exact (n_leq_add_n_k m k).
-Defined.
-
-Proposition nat_add_bifunctor (n n' m m' : nat)
-  : n <= m -> n' <= m' -> n + n' <= m + m'.
-Proof.
-  revert n' m m'; simple_induction n n IHn.
-  - intros n' m m' l l'. simpl.
-    apply (leq_trans l'). exact (n_leq_add_n_k' m' m).
-  - intros n' m; destruct m.
-    + intros. contradiction (not_leq_Sn_0 n).
-    + intros m' l l'. apply leq_S_n in l. simpl.
-      apply leq_S_n', IHn.
-      * exact l.
-      * exact l'.
-Defined.
-
-#[export] Hint Resolve nat_add_bifunctor : nat.
-#[export] Hint Resolve nataddpreserveslt : nat.
-#[export] Hint Resolve nataddpreservesleq' : nat.
-#[export] Hint Resolve nataddpreserveslt' : nat.
-#[export] Hint Resolve natineq0eq0 : nat.
-#[export] Hint Resolve n_leq_add_n_k : nat.
-#[export] Hint Resolve n_leq_m_n_leq_plus_m_k : nat.
-
-#[export] Hint Immediate add_n_sub_n_eq : nat.
-#[export] Hint Immediate add_n_sub_n_eq' : nat.
-
-#[export] Hint Rewrite <- add_n_O : nat.
-#[export] Hint Rewrite -> add_O_n : nat.
-#[export] Hint Rewrite -> add_n_sub_n_eq : nat.
-#[export] Hint Rewrite -> add_n_sub_n_eq' : nat.
-#[export] Hint Rewrite -> nataddsub_assoc : nat.
-
-Ltac autorewrite_or_fail := progress ltac:(autorewrite with nat).
-
-#[export] Hint Extern 7 => autorewrite_or_fail : nat.
-
-Proposition strong_induction (P : nat -> Type)
-  : (forall n : nat, (forall m : nat,  (m < n) -> P m) -> P n) ->
-  forall n : nat, P n.
-Proof.
-  intro a.
-  assert (forall n m: nat, m < n -> P m) as X. {
-    simple_induction n n IHn.
-    - intros m l. contradiction (not_lt_n_0 m).
-    - intros m l. apply leq_S_n in l.
-      destruct l as [ | n].
-      + apply a; intros ? ?; now apply IHn.
-      + now apply (IHn m), leq_S_n'.
-  }
-  intro n. apply (X (n.+1) n), (leq_n n.+1).
+  intro l; apply (leq_trans l); exact (leq_add_r m k).
 Defined.
 
 (** This inductive type is defined because it lets you loop from [i = 0] up to [i = n] by structural induction on a proof of [increasing_geq n 0]. With the existing [leq] type and the inductive structure of [n], it is easier and more natural to loop downwards from [i = n] to [i = 0], but harder to find the least natural number in the interval $[0,n]$ satisfying a given property. *)
@@ -830,48 +207,48 @@ Lemma increasing_geq_minus (n k : nat)
   : increasing_geq n (n - k).
 Proof.
   simple_induction k k IHk.
-  - destruct (symmetric_paths _ _ (sub_n_0 n)); constructor.
-  - destruct (@leq_dichot n k) as [l | g].
-    + destruct (symmetric_paths _ _ (sub_leq_0 _ _ _)) in IHk.
-      apply leq_S in l.
-      destruct (symmetric_paths _ _ (sub_leq_0 _ _ _)). exact IHk.
+  - destruct (symmetric_paths _ _ (nat_sub_zero_r n)); constructor.
+  - destruct (@leq_dichotomy n k) as [l | g].
+    + destruct (equiv_nat_sub_leq _)^ in IHk.
+      apply leq_succ_r in l.
+      destruct (equiv_nat_sub_leq _)^. exact IHk.
     + change k.+1 with (1 + k). destruct (nat_add_comm k 1).
-      destruct (symmetric_paths _ _ (subsubadd n k 1)).
+      destruct (symmetric_paths _ _ (nat_sub_r_add n k 1)).
       destruct (symmetric_paths _ _ (@predeqminus1 (n - k))).
       apply increasing_geq_S.
       unfold ">", "<" in *.
-      apply lt_sub_gt_0 in g. 
-      now (destruct (symmetric_paths _ _ (S_predn (n - k) 0 _))).
+      apply equiv_lt_lt_sub in g. 
+      now (destruct (symmetric_paths _ _ (nat_succ_pred (n - k) _))).
 Defined.
 
 Lemma ineq_sub' (n k : nat) : k < n -> n - k = (n - k.+1).+1.
 Proof.
   intro ineq.
   destruct n.
-  - contradiction (not_lt_n_0 k).
-  - change (n.+1 - k.+1) with (n - k). apply leq_S_n in ineq.
-    apply (nataddsub_assoc_lemma _).
+  - contradiction (not_lt_zero_r k).
+  - change (n.+1 - k.+1) with (n - k). apply leq_pred' in ineq.
+    by apply nat_sub_succ_l.
 Defined.
   
 Lemma ineq_sub (n m : nat) : n <= m -> m - (m - n) = n.
 Proof.
   revert m; simple_induction n n IHn.
-  - intros. destruct (symmetric_paths _ _ (sub_n_0 m)),
-      (symmetric_paths _ _ (sub_n_n m));
+  - intros. destruct (symmetric_paths _ _ (nat_sub_zero_r m)),
+      (symmetric_paths _ _ (nat_sub_cancel m));
       reflexivity.
   - intros m ineq. change (m - n.+1) with (m - (1 + n)).
     (destruct (nat_add_comm n 1)).
-    destruct (symmetric_paths _ _ (subsubadd m n 1)). 
-    destruct (S_predn (m - n) 0 (lt_sub_gt_0 _ _ ineq)); simpl;
-      destruct (symmetric_paths _ _ (sub_n_0 (pred (m - n)))).
-    assert (0 < m - n) as dp by exact (lt_sub_gt_0 _ _ ineq).
-    assert (pred (m - n) < m) as sh by
+    destruct (symmetric_paths _ _ (nat_sub_r_add m n 1)). 
+    destruct (nat_succ_pred (m - n) (equiv_lt_lt_sub _ _ ineq)); simpl;
+      destruct (symmetric_paths _ _ (nat_sub_zero_r (nat_pred (m - n)))).
+    assert (0 < m - n) as dp by exact (equiv_lt_lt_sub _ _ ineq).
+    assert (nat_pred (m - n) < m) as sh by
         ( unfold "<";
-          destruct (symmetric_paths _ _ (S_predn _ 0 _));
+          destruct (symmetric_paths _ _ (nat_succ_pred _ _));
           exact sub_less).
     destruct (symmetric_paths _ _ (ineq_sub' _ _ _)).
-    destruct (symmetric_paths _ _ (S_predn _ 0 _)).
-    apply (ap S), IHn, leq_S', ineq.
+    destruct (symmetric_paths _ _ (nat_succ_pred _ _)).
+    apply (ap S), IHn, leq_succ_l, ineq.
 Defined.                                 
   
 Proposition leq_equivalent (n m : nat)
@@ -884,16 +261,17 @@ Proof.
   - intro a.
     induction a.
     + constructor.
-    + exact (leq_S' _ _ _).
+    + exact (leq_succ_l _).
 Defined.
 
+(** TODO: remove *)
 (** This tautology accepts a (potentially opaqued or QED'ed) proof of [n <= m], and returns a transparent proof which can be computed with (i.e., one can loop from n to m) *) 
 Definition leq_wrapper {n m : nat} : n <= m -> n <= m.
 Proof.
   intro ineq.
-  destruct (@leq_dichot n m) as [l | g].
+  destruct (@leq_dichotomy n m) as [l | g].
   - exact l.
-  - contradiction (not_lt_n_n m (@mixed_trans2 _ _ _ g ineq)).
+  - contradiction (lt_irrefl m (lt_lt_leq_trans g ineq)).
 Defined.
 
 Proposition symmetric_rel_total_order (R : nat -> nat -> Type)
@@ -901,9 +279,9 @@ Proposition symmetric_rel_total_order (R : nat -> nat -> Type)
   : (forall n m : nat, n < m -> R n m) -> (forall n m : nat, R n m).
 Proof.
   intros A n m.
-  destruct (@leq_dichot m n) as [m_leq_n | m_gt_n].
+  destruct (@leq_dichotomy m n) as [m_leq_n | m_gt_n].
   - apply symmetry. destruct m_leq_n.
     + apply reflexivity.
-    + apply A. apply leq_S_n'. assumption.
+    + apply A. apply leq_succ. assumption.
   - apply A, m_gt_n.
 Defined.                             
diff --git a/theories/Spaces/Nat/Binomial.v b/theories/Spaces/Nat/Binomial.v
new file mode 100644
index 00000000000..31c4ec727e0
--- /dev/null
+++ b/theories/Spaces/Nat/Binomial.v
@@ -0,0 +1,157 @@
+Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids
+  Basics.Decidable Spaces.Nat.Core Spaces.Nat.Division Spaces.Nat.Factorial
+  Tactics.EvalIn.
+
+Local Set Universe Minimization ToSet.
+Local Unset Elimination Schemes.
+
+Local Open Scope nat_scope.
+
+(** * Binomial coefficients *)
+
+(** ** Definition *)
+
+(** The binomial coefficient [nat_choose n m] is the number of ways to choose [m] elements from a set of [n] elements. We define it recursively using Pascal's identity. We use nested [Fixpoint]s in order to get a function that computes definitionally on the edge cases as well as the inductive case. *)
+
+(** We separate out this helper result to prevent Coq from unfolding things into a larger term. This computes [n] choose [m.+1] given a function [f] that computes [n] choose [m]. *)
+Fixpoint nat_choose_step n f :=
+  match n with
+  | 0 => 0
+  | S n' => f n' + nat_choose_step n' f
+  end.
+
+Fixpoint nat_choose (n m : nat) {struct m} : nat
+  := match m with
+    | 0 => 1
+    | S m' => nat_choose_step n (fun n => nat_choose n m')
+    end.
+
+(** We make sure we never unfold binomial coefficients with [simpl] or [cbn] since the terms do not look good. Instead, we should use lemmas we prove about it to make proofs clearer to read. *)
+Arguments nat_choose n m : simpl never.
+
+(** ** Properties *)
+
+(** The three defining properties of [nat_choose] hold definitionally. *)
+
+(** By definition, we have Pascal's identity. *)
+Definition nat_choose_succ@{} n m
+  : nat_choose n.+1 m.+1 = nat_choose n m + nat_choose n m.+1
+  := idpath.
+
+(** There is only one way to choose [0] elements from any number of elements. *)
+Definition nat_choose_zero_r@{} n : nat_choose n 0 = 1
+  := idpath.
+
+(** There are no ways to choose a non-zero number of elements from [0] elements. *)
+Definition nat_choose_zero_l@{} m : nat_choose 0 m.+1 = 0
+  := idpath.
+
+(** The binomial coefficient is zero if [m] is greater than [n]. *)
+Definition nat_choose_lt@{} n m : n < m -> nat_choose n m = 0.
+Proof.
+  revert m; induction n; hnf; intros m H; destruct H.
+  1, 2: reflexivity.
+  1, 2: rewrite_refl nat_choose_succ; exact (ap011 nat_add (IHn _ _) (IHn _ _)).
+Defined.
+
+(** There is only one way to choose [n] elements from [n] elements. *)
+Definition nat_choose_diag@{} n : nat_choose n n = 1.
+Proof.
+  induction n as [|n IHn]; only 1: reflexivity.
+  rewrite_refl nat_choose_succ.
+  rhs_V nrapply nat_add_zero_r.
+  nrapply ap011.
+  - exact IHn.
+  - rapply nat_choose_lt.
+Defined.
+
+(** There are [n] ways to choose [1] element from [n] elements. *)
+Definition nat_choose_one_r@{} n : nat_choose n 1 = n.
+Proof.
+  induction n as [|n IHn]; only 1: reflexivity.
+  rewrite_refl nat_choose_succ.
+  exact (ap nat_succ IHn).
+Defined.
+
+(** There are [n.+1] ways to choose [n] elements from [n.+1] elements. *)
+Definition nat_choose_succ_l_diag@{} n : nat_choose n.+1 n = n.+1.
+Proof.
+  induction n as [|n IHn]; only 1: reflexivity.
+  rewrite_refl nat_choose_succ.
+  rhs_V nrapply (nat_add_comm _ 1).
+  nrapply ap011.
+  - exact IHn.
+  - apply nat_choose_diag.
+Defined.
+
+(** The binomial coefficients can be written as a quotient of factorials. This is typically used as a definition of the binomial coefficients. *)
+Definition nat_choose_factorial@{} n m
+  : m <= n -> nat_choose n m = factorial n / (factorial m * factorial (n - m)).
+Proof.
+  revert n m; apply nat_double_ind_leq; intro n.
+  (* The case when [m = 0]. *)
+  { rewrite nat_mul_one_l.
+    rewrite nat_sub_zero_r.
+    symmetry; rapply nat_div_cancel. }
+  (* The case when [m = n]. *)
+  { rewrite nat_sub_cancel.
+    rewrite nat_mul_one_r.
+    rewrite nat_div_cancel.
+    1: nrapply nat_choose_diag.
+    exact _. }
+  (* The case with [n.+1] and [m.+1] with [m < n] and an induction hypothesis. *)
+  intros m H IHn.
+  rewrite_refl nat_choose_succ.
+  rewrite 2 IHn.
+  2,3: exact _.
+  rewrite <- (nat_div_cancel_mul_l _ _ m.+1).
+  2: exact _.
+  rewrite nat_mul_assoc.
+  rewrite <- nat_factorial_succ.
+  rewrite <- (nat_div_cancel_mul_l (factorial n) _ (n - m)).
+  2: rapply equiv_lt_lt_sub.
+  rewrite nat_mul_assoc.
+  rewrite (nat_mul_comm (n - m) (factorial m.+1)).
+  rewrite <- nat_mul_assoc.
+  rewrite nat_sub_succ_r.
+  rewrite <- nat_factorial_pred.
+  2: rapply equiv_lt_lt_sub.
+  lhs_V nrapply nat_div_dist.
+  - rewrite nat_factorial_succ.
+    rewrite <- nat_mul_assoc.
+    exact _.
+  - rewrite <- nat_dist_r.
+    rewrite nat_add_succ_l.
+    rewrite nat_add_sub_r_cancel.
+    2: exact _.
+    rewrite <- nat_factorial_succ.
+    reflexivity.
+Defined.
+
+(** Another recursive property of the binomial coefficients.  To choose [m+1] elements from a set of size [n+1], one has [n+1] choices for the first element and then can make the remaining [m] choices from the remaining [n] elements.  This overcounts by a factor of [m+1], since there are [m+1] elements that could have been called the "first" element. *)
+Definition nat_choose_succ_mul@{} n m
+  : nat_choose n.+1 m.+1 = (n.+1 * nat_choose n m) / m.+1.
+Proof.
+  destruct (leq_dichotomy m n) as [H | H].
+  2: { rewrite 2 nat_choose_lt; only 2, 3: exact _.
+       rewrite nat_mul_zero_r.
+       symmetry; apply nat_div_zero_l. }
+  rewrite 2 nat_choose_factorial.
+  2,3: exact _.
+  rewrite nat_div_mul_l.
+  2: exact _.
+  rewrite nat_div_div_l.
+  by rewrite (nat_mul_comm _ m.+1), nat_mul_assoc.
+Defined.
+
+(** The binomial coefficients are symmetric about the middle of the range [0 <= n]. *)
+Definition nat_choose_sub@{} n m
+  : m <= n -> nat_choose n m = nat_choose n (n - m).
+Proof.
+  intros H.
+  rewrite 2 nat_choose_factorial.
+  2,3: exact _.
+  rewrite nat_sub_sub_cancel_r.
+  2: exact _.
+  by rewrite nat_mul_comm.
+Defined.
diff --git a/theories/Spaces/Nat/Core.v b/theories/Spaces/Nat/Core.v
index 86647eb1943..dbfddb3bccc 100644
--- a/theories/Spaces/Nat/Core.v
+++ b/theories/Spaces/Nat/Core.v
@@ -1,21 +1,12 @@
-(* -*- mode: coq; mode: visual-line -*- *)
-Require Import Basics Types.
-Require Export Basics.Nat.
-Require Export HoTT.DProp.
+Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids
+  Basics.Decidable Basics.Trunc Basics.Equivalences Basics.Nat
+  Basics.Classes Basics.Iff Types.Prod Types.Sum Types.Sigma.
+Export Basics.Nat.
 
 Local Set Universe Minimization ToSet.
-
 Local Unset Elimination Schemes.
 
-Scheme nat_ind := Induction for nat Sort Type.
-Scheme nat_rect := Induction for nat Sort Type.
-Scheme nat_rec := Minimality for nat Sort Type.
-
-(** * Theorems about the natural numbers *)
-
-(** Many of these definitions and proofs have been ported from the coq stdlib. *)
-
-(** Some results are prefixed with [nat_] and some are not.  Should we be more consistent? *)
+(** * Natural numbers *)
 
 (** We want to close the trunc_scope so that notations from there don't conflict here. *)
 Local Close Scope trunc_scope.
@@ -23,413 +14,529 @@ Local Open Scope nat_scope.
 
 (** ** Basic operations on naturals *)
 
-(** It is common to call [S] [succ] so we add it as a parsing only notation. *)
-Notation succ := S (only parsing).
+(** *** Iteration *)
+
+(** [n]th iteration of the function [f : A -> A].  We have definitional equalities [nat_iter 0 f x = x] and [nat_iter n.+1 f x = f (nat_iter n f x)].  We make this a notation, so it doesn't add a universe variable for the universe containing [A]. *)
+Notation nat_iter n f x
+  := ((fix F (m : nat)
+      := match m with
+        | 0 => x
+        | m'.+1 => f (F m')
+        end) n).
+
+(** *** Successor and predecessor *)
+
+(** [nat_succ n] is the successor of a natural number [n]. We defined a notation [x.+1] for it in Overture.v. *)
+Notation nat_succ := S (only parsing).
 
-(** The predecessor of a natural number. *)
-Definition pred n : nat :=
+(** [nat_pred n] is the predecessor of a natural number [n]. When [n] is [0] we return [0]. *)
+Definition nat_pred n : nat :=
   match n with
   | 0 => n
   | S n' => n'
   end.
 
+(** *** Arithmetic operations *)
+
 (** Addition of natural numbers *)
-Fixpoint add n m : nat :=
-  match n with
-  | 0 => m
-  | S n' => S (add n' m)
-  end.
+Definition nat_add n m : nat
+  := nat_iter n nat_succ m.
 
-Notation "n + m" := (add n m) : nat_scope.
+Notation "n + m" := (nat_add n m) : nat_scope.
 
-Definition double n : nat := n + n.
+(** Multiplication of natural numbers *)
+Definition nat_mul n m : nat
+  := nat_iter n (nat_add m) 0.
 
-Fixpoint mul n m : nat :=
-  match n with
-  | 0 => 0
-  | S n' => m + (mul n' m)
-  end.
-
-Notation "n * m" := (mul n m) : nat_scope.
+Notation "n * m" := (nat_mul n m) : nat_scope.
 
 (** Truncated subtraction: [n - m] is [0] if [n <= m] *)
-Fixpoint sub n m : nat :=
+Fixpoint nat_sub n m : nat :=
   match n, m with
-  | S n' , S m' => sub n' m'
+  | S n' , S m' => nat_sub n' m'
   | _ , _ => n
   end.
 
-Notation "n - m" := (sub n m) : nat_scope.
+Notation "n - m" := (nat_sub n m) : nat_scope.
+
+(** Powers or exponentiation of natural numbers. *)
+Definition nat_pow n m := nat_iter m (nat_mul n) 1.
 
-(** ** Minimum, maximum *)
+(** *** Maximum and minimum *)
 
-Fixpoint max n m :=
+(** The maximum [nat_max n m] of two natural numbers [n] and [m]. *)
+Fixpoint nat_max n m :=
   match n, m with
   | 0 , _ => m
   | S n' , 0 => n'.+1
-  | S n' , S m' => (max n' m').+1
+  | S n' , S m' => (nat_max n' m').+1
   end.
 
-Fixpoint min n m :=
+(** The minimum [nat_min n m] of two natural numbers [n] and [m]. *)
+Fixpoint nat_min n m :=
   match n, m with
   | 0 , _ => 0
   | S n' , 0 => 0
-  | S n' , S m' => S (min n' m')
+  | S n' , S m' => S (nat_min n' m')
   end.
 
-(** ** Power *)
+(** *** Euclidean division *)
 
-Fixpoint pow n m :=
-  match m with
-  | 0 => 1
-  | S m' => n * (pow n m')
-  end.
-
-(** ** Euclidean division *)
+(** This division takes time linear in `x` and is tail-recursive. In [nat_div_mod x y q u], [x + y.+1 * q + (y - u)] is the quantity being divided and [y] is the predecessor of the divisor.  It will be called with [q] zero and [u] equal to [y], so that [x] is the quantity being divided.  The return value is a pair [(q', u')] with [x + y.+1 * q + (y - u) = y.+1 * q' + (y - u')], at least when [u <= y], as shown in [nat_div_mod_spec_helper] in Nat/Divison.v. *)
 
-(** This division is linear and tail-recursive. In [divmod], [y] is the predecessor of the actual divisor, and [u] is [y] sub the real remainder. *)
-
-Fixpoint divmod x y q u : nat * nat :=
+Fixpoint nat_div_mod x y q u : nat * nat :=
   match x with
   | 0 => (q , u)
   | S x' =>
     match u with
-    | 0 => divmod x' y (S q) y
-    | S u' => divmod x' y q u'
+    | 0 => nat_div_mod x' y (S q) y
+    | S u' => nat_div_mod x' y q u'
     end
   end.
 
-Definition div x y : nat :=
+Definition nat_div x y : nat :=
   match y with
-    | 0 => y
-    | S y' => fst (divmod x y' 0 y')
+  | 0 => y
+  | S y' => fst (nat_div_mod x y' 0 y')
   end.
+Infix "/" := nat_div : nat_scope.
 
-Definition modulo x y : nat :=
+(** [nat_mod x y] is the remainder when [x] is divided by [y].  When [y] is zero, it is defined to be [x]. See [nat_div_mod_spec] and related results below. *)
+Definition nat_mod x y : nat :=
   match y with
-    | 0 => y
-    | S y' => y' - snd (divmod x y' 0 y')
+  | 0 => x
+  | S y' => y' - snd (nat_div_mod x y' 0 y')
   end.
+Infix "mod" := nat_mod : nat_scope.
 
-Infix "/" := div : nat_scope.
-Infix "mod" := modulo : nat_scope.
+(** For results about division and modulo, see Nat/Division.v. *)
 
-(** ** Greatest common divisor *)
+(** *** Greatest common divisor *)
 
 (** We use Euclid algorithm, which is normally not structural, but Coq is now clever enough to accept this (behind modulo there is a subtraction, which now preserves being a subterm) *)
 
-Fixpoint gcd a b :=
+Fixpoint nat_gcd a b :=
   match a with
   | O => b
-  | S a' => gcd (b mod a'.+1) a'.+1
+  | S a' => nat_gcd (b mod a'.+1) a'.+1
   end.
 
-(** ** Square *)
+(** ** Comparison predicates *)
 
-Definition square n : nat := n * n.
+(** *** Less than or equal To [<=] *)
 
-(** ** Square root *)
+Inductive leq (n : nat) : nat -> Type0 :=
+| leq_refl : leq n n
+| leq_succ_r m : leq n m -> leq n (S m).
 
-(** The following square root function is linear (and tail-recursive).
-  With Peano representation, we can't do better. For faster algorithm,
-  see Psqrt/Zsqrt/Nsqrt...
+Arguments leq_succ_r {n m} _.
 
-  We search the square root of n = k + p^2 + (q - r)
-  with q = 2p and 0<=r<=q. We start with p=q=r=0, hence
-  looking for the square root of n = k. Then we progressively
-  decrease k and r. When k = S k' and r=0, it means we can use (S p)
-  as new sqrt candidate, since (S k')+p^2+2p = k'+(S p)^2.
-  When k reaches 0, we have found the biggest p^2 square contained
-  in n, hence the square root of n is p.
-*)
+Scheme leq_ind := Induction for leq Sort Type.
+Scheme leq_rect := Induction for leq Sort Type.
+Scheme leq_rec := Induction for leq Sort Type.
 
-Fixpoint sqrt_iter k p q r : nat :=
-  match k with
-  | O => p
-  | S k' =>
-    match r with
-    | O => sqrt_iter k' p.+1 q.+2 q.+2
-    | S r' => sqrt_iter k' p q r'
-    end
-  end.
+Notation "n <= m" := (leq n m) : nat_scope.
 
-Definition sqrt n : nat := sqrt_iter n 0 0 0.
-
-(** ** Log2 *)
-
-(** This base-2 logarithm is linear and tail-recursive.
-
-  In [log2_iter], we maintain the logarithm [p] of the counter [q],
-  while [r] is the distance between [q] and the next power of 2,
-  more precisely [q + S r = 2^(S p)] and [r<2^p]. At each
-  recursive call, [q] goes up while [r] goes down. When [r]
-  is 0, we know that [q] has almost reached a power of 2,
-  and we increase [p] at the next call, while resetting [r]
-  to [q].
-
-  Graphically (numbers are [q], stars are [r]) :
-
-<<
-                    10
-                  9
-                8
-              7   *
-            6       *
-          5           ...
-        4
-      3   *
-    2       *
-  1   *       *
-0   *   *       *
->>
-
-  We stop when [k], the global downward counter reaches 0.
-  At that moment, [q] is the number we're considering (since
-  [k+q] is invariant), and [p] its logarithm.
-*)
-
-Fixpoint log2_iter k p q r : nat :=
-  match k with
-  | O    => p
-  | S k' =>
-    match r with
-    | O => log2_iter k' (S p) (S q) q
-    | S r' => log2_iter k' p (S q) r'
-    end
-  end.
+Existing Class leq.
+Global Existing Instances leq_refl leq_succ_r.
+
+(** *** Less than [<] *)
+
+(** We define the less-than relation [lt] in terms of [leq] *)
+Definition lt n m : Type0 := leq (S n) m.
+
+(** We declare it as an existing class so typeclass search is performed on its goals. *)
+Existing Class lt.
+#[export] Hint Unfold lt : typeclass_instances.
+Infix "<" := lt : nat_scope.
+Global Instance lt_is_leq n m : leq n.+1 m -> lt n m | 100 := idmap.
+
+(** *** Greater than or equal To [>=] *)
 
-Definition log2 n : nat := log2_iter (pred n) 0 1 0.
+Definition geq n m := leq m n.
+Existing Class geq.
+#[export] Hint Unfold geq : typeclass_instances.
+Infix ">=" := geq : nat_scope.
+Global Instance geq_is_leq n m : leq m n -> geq n m | 100 := idmap.
 
-Local Definition ap_S := @ap _ _ S.
-Local Definition ap_nat := @ap nat.
-#[export] Hint Resolve ap_S : core.
-#[export] Hint Resolve ap_nat : core.
+(*** Greater Than [>] *)
 
-Theorem pred_Sn : forall n:nat, n = pred (S n).
+Definition gt n m := lt m n.
+Existing Class gt.
+#[export] Hint Unfold gt : typeclass_instances.
+Infix ">" := gt : nat_scope.
+Global Instance gt_is_leq n m : leq m.+1 n -> gt n m | 100 := idmap.
+
+(** *** Combined comparison predicates *)
+
+Notation "x <= y <= z" := (x <= y /\ y <= z) : nat_scope.
+Notation "x <= y < z"  := (x <= y /\ y <  z) : nat_scope.
+Notation "x < y < z"   := (x <  y /\ y <  z) : nat_scope.
+Notation "x < y <= z"  := (x <  y /\ y <= z) : nat_scope.
+
+(** ** Properties of [nat_iter]. *)
+
+Definition nat_iter_succ_r n {A} (f : A -> A) (x : A)
+  : nat_iter (S n) f x = nat_iter n f (f x).
 Proof.
-  auto.
+  simple_induction n n IHn; simpl; trivial.
+  exact (ap f IHn).
 Defined.
 
-(** Injectivity of successor *)
+Definition nat_iter_add (n m : nat) {A} (f : A -> A) (x : A)
+  : nat_iter (n + m) f x = nat_iter n f (nat_iter m f x).
+Proof.
+  simple_induction n n IHn; simpl; trivial.
+  exact (ap f IHn).
+Defined.
+
+(** Preservation of invariants : if [f : A -> A] preserves the invariant [P], then the iterates of [f] also preserve it. *)
+Definition nat_iter_invariant (n : nat) {A} (f : A -> A) (P : A -> Type)
+  : (forall x, P x -> P (f x)) -> forall x, P x -> P (nat_iter n f x).
+Proof.
+  simple_induction n n IHn; simpl; trivial.
+  intros Hf x Hx.
+  apply Hf, IHn; trivial.
+Defined.
+
+(** ** Properties of successors *)
 
-Definition path_nat_S n m (H : S n = S m) : n = m := ap pred H.
-#[export] Hint Immediate path_nat_S : core.
+(** The predecessor of a successor is the original number. *)
+Definition nat_pred_succ@{} n : nat_pred (nat_succ n) = n
+  := idpath.
 
-Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m.
+(** The successor of a predecessor is the original as long as there is a strict lower bound. *)
+Definition nat_succ_pred'@{} n i : i < n -> nat_succ (nat_pred n) = n.
 Proof.
-  auto.
+  by intros [].
 Defined.
-#[export] Hint Resolve not_eq_S : core.
 
-(** TODO: keep or remove? *)
-Definition IsSucc (n: nat) : Type0 :=
-  match n with
-  | O => Empty
-  | S p => Unit
-  end.
+(** The most common lower bound is to take [0]. *)
+Definition nat_succ_pred@{} n : 0 < n -> nat_succ (nat_pred n) = n
+  := nat_succ_pred' n 0.
+
+(** Injectivity of successor. *)
+Definition path_nat_succ@{} n m (H : S n = S m) : n = m := ap nat_pred H.
+Global Instance isinj_succ : IsInjective nat_succ := path_nat_succ.
 
-(** Zero is not the successor of a number *)
+(** Inequality of sucessors is implied with inequality of the arguments. *)
+Definition neq_nat_succ@{} n m : n <> m -> S n <> S m.
+Proof.
+  intros np q.
+  apply np.
+  exact (path_nat_succ _ _ q).
+Defined.
 
-Theorem not_eq_O_S : forall n:nat, 0 <> S n.
+(** Zero is not the successor of a number. *)
+Definition neq_nat_zero_succ@{} n : 0 <> S n.
 Proof.
   discriminate.
 Defined.
-#[export] Hint Resolve not_eq_O_S : core.
 
-Theorem not_eq_n_Sn : forall n:nat, n <> S n.
+(** A natural number cannot be equal to its own successor. *)
+Definition neq_nat_succ'@{} n : n <> S n.
 Proof.
-  simple_induction' n; auto.
+  simple_induction' n.
+  - apply neq_nat_zero_succ.
+  - by apply neq_nat_succ.
 Defined.
-#[export] Hint Resolve not_eq_n_Sn : core.
 
-Local Definition ap011_add := @ap011 _ _ _ add.
-Local Definition ap011_nat := @ap011 nat nat.
-#[export] Hint Resolve ap011_add : core.
-#[export] Hint Resolve ap011_nat : core.
+(** ** Truncatedness of natural numbers *)
 
-Lemma add_n_O : forall (n : nat), n = n + 0.
+(** [nat] has decidable paths. *)
+Global Instance decidable_paths_nat@{} : DecidablePaths nat.
 Proof.
-  simple_induction' n; simpl; auto.
+  intros n m.
+  induction n as [|n IHn] in m |- *; destruct m.
+  - exact (inl idpath).
+  - exact (inr (neq_nat_zero_succ m)).
+  - exact (inr (fun p => neq_nat_zero_succ n p^)).
+  - destruct (IHn m) as [p|q].
+    + exact (inl (ap S p)).
+    + exact (inr (fun p => q (path_nat_succ _ _ p))).
 Defined.
-#[export] Hint Resolve add_n_O : core.
 
-Lemma add_O_n : forall (n : nat), 0 + n = n.
+(** [nat] is therefore a hset. *)
+Global Instance ishset_nat : IsHSet nat := _.
+
+(** ** Properties of addition *)
+
+(** [0] is the left identity of addition. *)
+Definition nat_add_zero_l@{} n : 0 + n = n
+  := idpath.
+
+(** [0] is the right identity of addition. *)
+Definition nat_add_zero_r@{} n : n + 0 = n.
 Proof.
-  auto.
+  induction n as [|n IHn].
+  - reflexivity.
+  - apply (ap nat_succ).
+    exact IHn.
 Defined.
 
-Lemma add_n_Sm : forall n m:nat, S (n + m) = n + S m.
+(** Adding a successor on the left is the same as adding and then taking the successor. *)
+Definition nat_add_succ_l@{} n m : n.+1 + m = (n + m).+1
+  := idpath.
+
+(** Adding a successor on the right is the same as adding and then taking the successor. *)
+Definition nat_add_succ_r@{} n m : n + m.+1 = (n + m).+1.
 Proof.
-  simple_induction' n; simpl; auto.
+  simple_induction' n; simpl.
+  1: reflexivity.
+  exact (ap S IH).
 Defined.
-#[export] Hint Resolve add_n_Sm: core.
 
-Lemma add_Sn_m : forall n m:nat, S n + m = S (n + m).
+(** Addition of natural numbers is commutative. *)
+Definition nat_add_comm@{} n m : n + m = m + n.
 Proof.
-  auto.
+  induction n.
+  - exact (nat_add_zero_r m)^.
+  - rhs nrapply nat_add_succ_r.
+    apply (ap nat_succ).
+    exact IHn.
 Defined.
 
-(** Multiplication *)
+(** Addition of natural numbers is associative. *)
+Definition nat_add_assoc@{} n m k : n + (m + k) = (n + m) + k.
+Proof.
+  induction n as [|n IHn].
+  - reflexivity.
+  - nrapply (ap nat_succ).
+    exact IHn.
+Defined.
 
-Local Definition ap011_mul := @ap011 _ _ _  mul.
-#[export] Hint Resolve ap011_mul : core.
+(** Addition on the left is injective. *)
+Global Instance isinj_nat_add_l@{} k : IsInjective (nat_add k).
+Proof.
+  simple_induction k k Ik; exact _.
+Defined.
 
-Lemma mul_n_O : forall n:nat, 0 = n * 0.
+(** Addition on the right is injective. *)
+Definition isinj_nat_add_r@{} k : IsInjective (fun x => nat_add x k).
 Proof.
-  simple_induction' n; simpl; auto.
+  intros x y H.
+  nrapply (isinj_nat_add_l k).
+  lhs nrapply nat_add_comm.
+  lhs nrapply H.
+  nrapply nat_add_comm.
 Defined.
-#[export] Hint Resolve mul_n_O : core.
 
-Lemma mul_n_Sm : forall n m:nat, n * m + n = n * S m.
+(** A sum being zero is equivalent to both summands being zero. *)
+Definition equiv_nat_add_zero n m : n = 0 /\ m = 0 <~> n + m = 0.
 Proof.
-  intros; simple_induction n p H; simpl; auto.
-  destruct H; rewrite <- add_n_Sm; apply ap.
-  pattern m at 1 3; elim m; simpl; auto.
+  srapply equiv_iff_hprop.
+  - intros [-> ->]; reflexivity.
+  - destruct n.
+    + by split.
+    + intros H; symmetry in H.
+      by apply neq_nat_zero_succ in H.
 Defined.
-#[export] Hint Resolve mul_n_Sm: core.
 
-(** Standard associated names *)
+(** ** Properties of multiplication *)
 
-Notation mul_0_r_reverse := mul_n_O (only parsing).
-Notation mul_succ_r_reverse := mul_n_Sm (only parsing).
+(** Multiplication by [0] on the left is [0]. *)
+Definition nat_mul_zero_l@{} n : 0 * n = 0
+  := idpath.
 
-(** ** Equality of natural numbers *)
+(** Multiplicaiton by [0] on the right is [0]. *)
+Definition nat_mul_zero_r@{} n : n * 0 = 0.
+Proof.
+  by induction n.
+Defined.
 
-(** *** Boolean equality and its properties *)
+Definition nat_mul_succ_l@{} n m : n.+1 * m = m + n * m
+  := idpath.
 
-Fixpoint code_nat (m n : nat) {struct m} : DHProp@{Set} :=
-  match m, n with
-  | 0, 0 => True
-  | m'.+1, n'.+1 => code_nat m' n'
-  | _, _ => False
-  end.
+Definition nat_mul_succ_r@{} n m : n * m.+1 = n * m + n.
+Proof.
+  induction n as [|n IHn].
+  - reflexivity.
+  - rhs nrapply nat_add_succ_r.
+    nrapply (ap nat_succ).
+    rhs_V nrapply nat_add_assoc.
+    nrapply (ap (nat_add m)).
+    exact IHn.
+Defined.
 
-Infix "=n" := code_nat : nat_scope.
+(** Multiplication of natural numbers is commutative. *)
+Definition nat_mul_comm@{} n m : n * m = m * n.
+Proof.
+  induction m as [|m IHm]; simpl.
+  - nrapply nat_mul_zero_r.
+  - lhs nrapply nat_mul_succ_r.
+    lhs nrapply nat_add_comm.
+    snrapply (ap (nat_add n)).
+    exact IHm.
+Defined.
 
-Fixpoint idcode_nat {n} : (n =n n) :=
-  match n as n return (n =n n) with
-  | 0 => tt
-  | S n' => @idcode_nat n'
-  end.
+(** Multiplication of natural numbers distributes over addition on the left. *)
+Definition nat_dist_l@{} n m k : n * (m + k) = n * m + n * k.
+Proof.
+  induction n as [|n IHn]; simpl.
+  - reflexivity.
+  - lhs_V nrapply nat_add_assoc.
+    rhs_V nrapply nat_add_assoc.
+    nrapply (ap (nat_add m)).
+    lhs nrapply nat_add_comm.
+    rewrite IHn.
+    lhs_V nrapply nat_add_assoc.
+    nrapply (ap (nat_add (n * m))).
+    nrapply nat_add_comm.
+Defined.
 
-Fixpoint path_nat {n m} : (n =n m) -> (n = m) :=
-  match m as m, n as n return (n =n m) -> (n = m) with
-  | 0, 0 => fun _ => idpath
-  | m'.+1, n'.+1 => fun H : (n' =n m') => ap S (path_nat H)
-  | _, _ => fun H => match H with end
-  end.
+(** Multiplication of natural numbers distributes over addition on the right. *)
+Definition nat_dist_r@{} n m k : (n + m) * k = n * k + m * k.
+Proof.
+  lhs nrapply nat_mul_comm.
+  lhs nrapply nat_dist_l.
+  nrapply ap011; nrapply nat_mul_comm.
+Defined.
 
-Global Instance isequiv_path_nat {n m} : IsEquiv (@path_nat n m).
+(** Multiplication of natural numbers is associative. *)
+Definition nat_mul_assoc@{} n m k : n * (m * k) = n * m * k.
 Proof.
-  refine (isequiv_adjointify
-            (@path_nat n m)
-            (fun H => transport (fun m' => (n =n m')) H idcode_nat)
-            _ _).
-  { intros []; simpl.
-    induction n; simpl; trivial.
-    by destruct (IHn^)%path. }
-  { intro. apply path_ishprop. }
+  induction n as [|n IHn]; simpl.
+  - reflexivity.
+  - rhs nrapply nat_dist_r.
+    nrapply (ap (nat_add (m * k))).
+    exact IHn.
 Defined.
 
-Definition equiv_path_nat {n m} : (n =n m) <~> (n = m)
-  := Build_Equiv _ _ (@path_nat n m) _.
+(** Multiplication by [1] on the left is the identity. *)
+Definition nat_mul_one_l@{} n : 1 * n = n
+  := nat_add_zero_r _.
 
-(** Thus [nat] has decidable paths *)
-Global Instance decidable_paths_nat : DecidablePaths nat
-  := fun n m => decidable_equiv _ (@path_nat n m) _.
+(** Multiplication by [1] on the right is the identity. *)
+Definition nat_mul_one_r@{} n : n * 1 = n
+  := nat_mul_comm _ _ @ nat_mul_one_l _.
 
-(** And is therefore a HSet *)
-Global Instance hset_nat : IsHSet nat := _.
+(** ** Basic properties of comparison predicates *)
 
-(** ** Inequality of natural numbers *)
+(** *** Basic properties of [<=] *)
 
-Cumulative Inductive leq (n : nat) : nat -> Type0 :=
-| leq_n : leq n n
-| leq_S : forall m, leq n m -> leq n (S m).
+(** [<=] is reflexive by definition. *)
+Global Instance reflexive_leq : Reflexive leq := leq_refl.
 
-Scheme leq_ind := Induction for leq Sort Type.
-Scheme leq_rect := Induction for leq Sort Type.
-Scheme leq_rec := Minimality for leq Sort Type.
+(** Being less than or equal to is a transitive relation. *)
+Definition leq_trans {x y z} : x <= y -> y <= z -> x <= z.
+Proof.
+  intros H1 H2; induction H2; exact _.
+Defined.
+Hint Immediate leq_trans : typeclass_instances.
 
-Notation "n <= m" := (leq n m) : nat_scope.
-#[export] Hint Constructors leq : core.
+(** [<=] is transtiive. *)
+Global Instance transitive_leq : Transitive leq := @leq_trans.
 
-Existing Class leq.
-Global Existing Instances leq_n leq_S.
+(** [0] is less than or equal to any natural number. *)
+Definition leq_zero_l n : 0 <= n.
+Proof.
+  simple_induction' n; exact _.
+Defined.
+Global Existing Instance leq_zero_l | 10.
 
-Notation leq_refl := leq_n (only parsing).
-Global Instance reflexive_leq : Reflexive leq := leq_n.
+(** A predecessor is less than or equal to a predecessor if the original number is less than or equal. *)
+Global Instance leq_pred {n m} : n <= m -> nat_pred n <= nat_pred m.
+Proof.
+  intros H; induction H.
+  1: exact _.
+  destruct m; exact _.
+Defined.
 
-Lemma leq_trans {x y z} : x <= y -> y <= z -> x <= z.
+(** A successor is less than or equal to a successor if the original numbers are less than or equal. *)
+Definition leq_succ {n m} : n <= m -> n.+1 <= m.+1.
 Proof.
-  induction 2; auto.
+  induction 1; exact _.
 Defined.
+Global Existing Instance leq_succ | 100.
 
-Global Instance transitive_leq : Transitive leq := @leq_trans.
+(** The converse to [leq_succ] also holds. *)
+Definition leq_pred' {n m} : n.+1 <= m.+1 -> n <= m := leq_pred.
+Hint Immediate leq_pred' : typeclass_instances.
 
-Lemma leq_n_pred n m : leq n m -> leq (pred n) (pred m).
+(** [<] is an irreflexive relation. *)
+Definition lt_irrefl n : ~ (n < n).
 Proof.
-  induction 1; auto.
-  destruct m; simpl; auto.
+  induction n as [|n IHn].
+  1: intro p; inversion p.
+  intros p; by apply IHn, leq_pred'.
 Defined.
 
-Lemma leq_S_n : forall n m, n.+1 <= m.+1 -> n <= m.
+Global Instance irreflexive_lt : Irreflexive lt := lt_irrefl.
+Global Instance irreflexive_gt : Irreflexive gt := lt_irrefl.
+
+(** [<=] is an antisymmetric relation. *)
+Definition leq_antisym {x y} : x <= y -> y <= x -> x = y.
 Proof.
-  intros n m.
-  apply leq_n_pred.
+  intros p q.
+  destruct p.
+  1: reflexivity.
+  destruct x; [inversion q|].
+  apply leq_pred' in q.
+  contradiction (lt_irrefl _ (leq_trans p q)).
+Defined.
+
+Global Instance antisymmetric_leq : AntiSymmetric leq := @leq_antisym.
+Global Instance antisymemtric_geq : AntiSymmetric geq
+  := fun _ _ p q => leq_antisym q p.
+
+(** Every natural number is zero or greater than zero. *)
+Definition nat_zero_or_gt_zero n : (0 = n) + (0 < n).
+Proof.
+  induction n as [|n IHn].
+  1: left; reflexivity.
+  right; exact _.
 Defined.
 
-Lemma leq_S_n' n m : n <= m -> n.+1 <= m.+1.
+(** Being less than or equal to [0] implies being [0]. *)
+Definition path_zero_leq_zero_r n : n <= 0 -> n = 0.
 Proof.
-  induction 1; auto.
+  intros H; rapply leq_antisym.
 Defined.
-Global Existing Instance leq_S_n' | 100.
 
-Lemma not_leq_Sn_n n : ~ (n.+1 <= n).
+(** Nothing can be less than [0]. *)
+Definition not_lt_zero_r n : ~ (n < 0).
 Proof.
-  simple_induction n n IHn.
-  { intro p.
-    inversion p. }
   intros p.
-  by apply IHn, leq_S_n.
+  apply (lt_irrefl n), (leq_trans p).
+  exact _.
 Defined.
 
 (** A general form for injectivity of this constructor *)
-Definition leq_n_inj_gen n k (p : n <= k) (r : n = k) : p = r # leq_n n.
+Definition leq_refl_inj_gen n k (p : n <= k) (r : n = k) : p = r # leq_refl n.
 Proof.
   destruct p.
   + assert (c : idpath = r) by apply path_ishprop.
     destruct c.
     reflexivity.
   + destruct r^.
-    contradiction (not_leq_Sn_n _ p).
+    contradiction (lt_irrefl _ p).
 Defined.
 
 (** Which we specialise to this lemma *)
-Definition leq_n_inj n (p : n <= n) : p = leq_n n
-  := leq_n_inj_gen n n p idpath.
+Definition leq_refl_inj n (p : n <= n) : p = leq_refl n
+  := leq_refl_inj_gen n n p idpath.
 
-Fixpoint leq_S_inj_gen n m k (p : n <= k) (q : n <= m) (r : m.+1 = k)
-  : p = r # leq_S n m q.
+Fixpoint leq_succ_r_inj_gen n m k (p : n <= k) (q : n <= m) (r : m.+1 = k)
+  : p = r # leq_succ_r q.
 Proof.
   revert m q r.
   destruct p.
   + intros k p r.
     destruct r.
-    contradiction (not_leq_Sn_n _ p).
+    contradiction (lt_irrefl _ p).
   + intros m' q r.
-    pose (r' := path_nat_S _ _ r).
+    pose (r' := path_nat_succ _ _ r).
     destruct r'.
     assert (t : idpath = r) by apply path_ishprop.
     destruct t.
     cbn. apply ap.
     destruct q.
-    1:  apply leq_n_inj.
-    apply (leq_S_inj_gen n m _ p q idpath).
+    1:  apply leq_refl_inj.
+    apply (leq_succ_r_inj_gen n m _ p q idpath).
 Defined.
 
-Definition leq_S_inj n m (p : n <= m.+1) (q : n <= m) : p = leq_S n m q
-  := leq_S_inj_gen n m m.+1 p q idpath.
+Definition leq_succ_r_inj n m (p : n <= m.+1) (q : n <= m) : p = leq_succ_r q
+  := leq_succ_r_inj_gen n m m.+1 p q idpath.
 
 Global Instance ishprop_leq n m : IsHProp (n <= m).
 Proof.
@@ -437,27 +544,14 @@ Proof.
   intros p q; revert p.
   induction q.
   + intros y.
-    rapply leq_n_inj.
+    rapply leq_refl_inj.
   + intros y.
-    rapply leq_S_inj.
-Defined.
-
-Global Instance leq_0_n n : 0 <= n | 10.
-Proof.
-  simple_induction' n; auto.
+    rapply leq_succ_r_inj.
 Defined.
 
-Lemma not_leq_Sn_0 n : ~ (n.+1 <= 0).
-Proof.
-  intros p.
-  apply (fun x => leq_trans x (leq_0_n n)) in p.
-  contradiction (not_leq_Sn_n _ p).
-Defined.
-
-Definition equiv_leq_S_n n m : n.+1 <= m.+1 <~> n <= m.
+Definition equiv_leq_succ n m : n.+1 <= m.+1 <~> n <= m.
 Proof.
   srapply equiv_iff_hprop.
-  apply leq_S_n.
 Defined.
 
 Global Instance decidable_leq n m : Decidable (n <= m).
@@ -466,282 +560,960 @@ Proof.
   simple_induction' m; intros n.
   - destruct n.
     + left; exact _.
-    + right; apply not_leq_Sn_0.
+    + right; apply not_lt_zero_r.
   - destruct n.
     + left; exact _.
     + rapply decidable_equiv'.
       symmetry.
-      apply equiv_leq_S_n.
+      apply equiv_leq_succ.
 Defined.
 
-Fixpoint leq_add n m : n <= (m + n).
+(** [n.+1 <= m] implies [n <= m]. *)
+Definition leq_succ_l {n m} : n.+1 <= m -> n <= m.
 Proof.
-  destruct m.
-  1: apply leq_n.
-  apply leq_S, leq_add.
+  intro l; apply leq_pred'; exact _.
 Defined.
 
-Lemma equiv_leq_add n m
-  : leq n m <~> exists k, k + n = m.
-Proof.
-  srapply equiv_iff_hprop.
-  { apply hprop_allpath.
-    intros [x p] [y q].
-    apply path_sigma_hprop.
-    simpl.
-    revert m p q.
-    induction n.
-    { intros m p q.
-      rewrite <- add_n_O in p,q.
-      exact (p @ q^). }
-    intros m p q.
-    rewrite <- add_n_Sm in p,q.
-    destruct m.
-    { inversion p. }
-    apply path_nat_S in p, q.
-    by apply (IHn m). }
-  { intros p.
-    induction p.
-    + exists 0.
-      reflexivity.
-    + exists IHp.1.+1.
-      apply ap_S, IHp.2. }
-  intros [k p].
-  destruct p.
-  apply leq_add.
-Defined.
+(** *** Basic properties of [<] *)
 
-(** We define the less-than relation [lt] in terms of [leq] *)
-Definition lt n m : Type0 := leq (S n) m.
+(** [<=] and [<] imply [<] *)
+Definition lt_leq_lt_trans {n m k} : n <= m -> m < k -> n < k
+  := fun leq lt => leq_trans (leq_succ leq) lt.
 
-(** We declare it as an existing class so typeclass search is performed on its goals. *)
-Existing Class lt.
-#[export] Hint Unfold lt : core typeclass_instances.
-Infix "<" := lt : nat_scope.
-(** We add a typeclass instance for unfolding the definition so lemmas about [leq] can be used. *)
-Global Instance lt_is_leq n m : leq n.+1 m -> lt n m | 100 := idmap.
+(** [<=] and [<] imply [<] *)
+Definition lt_lt_leq_trans {n m k} : n < m -> m <= k -> n < k
+  := fun lt leq => leq_trans lt leq.
 
-(** We should also give them their various typeclass instances *)
-Global Instance transitive_lt : Transitive lt.
-Proof.
-  hnf; unfold lt in *.
-  intros x y z p q.
-  rapply leq_trans.
-Defined.
+Definition leq_lt {n m} : n < m -> n <= m
+  := leq_succ_l.
+Hint Immediate leq_lt : typeclass_instances.
+
+Definition lt_trans {n m k} : n < m -> m < k -> n < k
+  := fun H1 H2 => leq_lt (lt_leq_lt_trans H1 H2).
+Hint Immediate lt_trans : typeclass_instances.
 
+Global Instance transitive_lt : Transitive lt := @lt_trans.
+Global Instance ishprop_lt n m : IsHProp (n < m) := _.
 Global Instance decidable_lt n m : Decidable (lt n m) := _.
 
-Definition ge n m := leq m n.
-Existing Class ge.
-#[export] Hint Unfold ge : core typeclass_instances.
-Infix ">=" := ge : nat_scope.
-Global Instance ge_is_leq n m : leq m n -> ge n m | 100 := idmap.
+(** *** Basic properties of [>=] *)
 
-Global Instance reflexive_ge : Reflexive ge := leq_n.
-Global Instance transitive_ge : Transitive ge := fun x y z p q => leq_trans q p.
-Global Instance decidable_ge n m : Decidable (ge n m) := _.
+Global Instance reflexive_geq : Reflexive geq := leq_refl.
+Global Instance transitive_geq : Transitive geq := fun x y z p q => leq_trans q p.
+Global Instance ishprop_geq n m : IsHProp (geq n m) := _.
+Global Instance decidable_geq n m : Decidable (geq n m) := _.
 
-Definition gt n m := lt m n.
-Existing Class gt.
-#[export] Hint Unfold gt : core typeclass_instances.
-Infix ">" := gt : nat_scope.
-Global Instance gt_is_leq n m : leq m.+1 n -> gt n m | 100 := idmap.
+(** *** Basic properties of [>] *)
 
 Global Instance transitive_gt : Transitive gt
   := fun x y z p q => transitive_lt _ _ _ q p.
+Global Instance ishprop_gt n m : IsHProp (gt n m) := _.
 Global Instance decidable_gt n m : Decidable (gt n m) := _.
 
-Notation "x <= y <= z" := (x <= y /\ y <= z) : nat_scope.
-Notation "x <= y < z"  := (x <= y /\  y < z) : nat_scope.
-Notation "x < y < z"   := (x < y  /\  y < z) : nat_scope.
-Notation "x < y <= z"  := (x < y  /\ y <= z) : nat_scope.
+(** ** Properties of subtraction *)
 
-(** Principle of double induction *)
+(** Subtracting a number from [0] is [0]. *)
+Definition nat_sub_zero_l@{} n : 0 - n = 0 := idpath.
 
-Theorem nat_double_ind (R : nat -> nat -> Type)
-  (H1 : forall n, R 0 n) (H2 : forall n, R (S n) 0)
-  (H3 : forall n m, R n m -> R (S n) (S m))
-  : forall n m:nat, R n m.
+(** Subtracting [0] from a number is the number itself. *)
+Definition nat_sub_zero_r@{} (n : nat) : n - 0 = n.
 Proof.
-  simple_induction' n; auto.
-  destruct m; auto.
+  destruct n; reflexivity.
 Defined.
 
-(** Maximum and minimum : definitions and specifications *)
+(** Subtracting a number from itself is [0]. *)
+Definition nat_sub_cancel@{} (n : nat) : n - n = 0.
+Proof.
+  simple_induction n n IHn.
+  - reflexivity.
+  - exact IHn.
+Defined.
 
-Lemma max_n_n n : max n n = n.
+(** Subtracting an addition is the same as subtracting the two numbers separately. *)
+Definition nat_sub_r_add@{} n m k : n - (m + k) = n - m - k.
 Proof.
-  simple_induction' n; cbn; auto.
+  induction n as [|n IHn] in m, k |- *.
+  - reflexivity.
+  - destruct m.
+    + reflexivity.
+    + nrapply IHn.
 Defined.
-#[export] Hint Resolve max_n_n : core.
 
-Lemma max_Sn_n n : max (S n) n = S n.
+(** The order in which two numbers are subtracted does not matter. *)
+Definition nat_sub_comm_r@{} n m k : n - m - k = n - k - m.
 Proof.
-  simple_induction' n; cbn; auto.
+  lhs_V nrapply nat_sub_r_add.
+  rewrite nat_add_comm.
+  nrapply nat_sub_r_add.
 Defined.
-#[export] Hint Resolve max_Sn_n : core.
 
-Lemma max_comm n m : max n m = max m n.
+(** Subtracting a larger number from a smaller number is [0]. *)
+Definition equiv_nat_sub_leq {n m} : n <= m <~> n - m = 0.
 Proof.
-  revert m; simple_induction' n; destruct m; cbn; auto.
+  srapply equiv_iff_hprop.
+  - intro l; induction l.
+    + exact (nat_sub_cancel n).
+    + change (m.+1) with (1 + m).
+      lhs nrapply nat_sub_r_add.
+      lhs nrapply nat_sub_comm_r.
+      by destruct IHl^.
+  - induction n as [|n IHn] in m |- *.
+    1: intro; exact _.
+    destruct m.
+    + intros p; by destruct p.
+    + intros p.
+      apply leq_succ, IHn.
+      exact p.
 Defined.
 
-Lemma max_0_n n : max 0 n = n.
+(** We can cancel a left summand when subtracting it from a sum. *)
+Definition nat_add_sub_cancel_l m n : n + m - n = m.
 Proof.
-  auto.
+  induction n as [|n IHn].
+  - nrapply nat_sub_zero_r.
+  - exact IHn.
 Defined.
-#[export] Hint Resolve max_0_n : core.
 
-Lemma max_n_0 n : max n 0 = n.
+(** We can cancel a right summand when subtracting it from a sum. *)
+Definition nat_add_sub_cancel_r m n : m + n - n = m.
 Proof.
-  by rewrite max_comm.
+  rhs_V nrapply (nat_add_sub_cancel_l m n).
+  nrapply (ap (fun x => x - n)).
+  nrapply nat_add_comm.
 Defined.
-#[export] Hint Resolve max_n_0 : core.
 
-Theorem max_l : forall n m, m <= n -> max n m = n.
+(** We can cancel a right subtrahend when adding it on the right to a subtraction if the subtrahend is less than the number being subtracted from. *)
+Definition nat_add_sub_l_cancel {n m} : n <= m -> (m - n) + n = m.
 Proof.
-  intros n m; revert n; simple_induction m m IHm; auto.
-  intros [] p.
-  1: inversion p.
-  cbn; by apply ap_S, IHm, leq_S_n.
+  intros H.
+  induction n as [|n IHn] in m, H |- *.
+  - lhs nrapply nat_add_zero_r.
+    nrapply nat_sub_zero_r.
+  - destruct m.
+    1: contradiction (not_lt_zero_r n).
+    lhs nrapply nat_add_succ_r.
+    nrapply (ap nat_succ).
+    nrapply IHn.
+    exact (leq_pred' H).
+Defined.
+
+(** We can cancel a right subtrahend when adding it on the left to a subtraction if the subtrahend is less than the nubmer being subtracted from. *)
+Definition nat_add_sub_r_cancel {n m} : n <= m -> n + (m - n) = m.
+Proof.
+  intros H.
+  rhs_V nrapply (nat_add_sub_l_cancel H).
+  apply nat_add_comm.
+Defined.
+
+(** We can move a subtracted number to the left-hand side of an equation. *)
+Definition nat_moveL_nV {n m} k : n + k = m -> n = m - k.
+Proof.
+  intros p.
+  destruct p.
+  symmetry.
+  apply nat_add_sub_cancel_r.
+Defined.
+
+(** We can move a subtracted number to the right-hand side of an equation. *)
+Definition nat_moveR_nV {n m} k : n = m + k -> n - k = m
+  := fun p => (nat_moveL_nV _ p^)^.
+
+(** Subtracting a successor is the predecessor of subtracting the original number. *)
+Definition nat_sub_succ_r n m : n - m.+1 = nat_pred (n - m).
+Proof.
+  induction n as [|n IHn] in m |- *.
+  1: reflexivity.
+  destruct m.
+  1: apply nat_sub_zero_r.
+  apply IHn.
+Defined.
+
+(** ** Properties of maximum and minimum *)
+
+(** *** Properties of maximum *)
+
+(** [nat_max] is idempotent. *)
+Definition nat_max_idem@{} n : nat_max n n = n.
+Proof.
+  simple_induction' n; cbn.
+  1: reflexivity.
+  exact (ap S IH).
+Defined.
+
+(** [nat_max] is commutative. *)
+Definition nat_max_comm@{} n m : nat_max n m = nat_max m n.
+Proof.
+  induction n as [|n IHn] in m |- *; destruct m; cbn.
+  1-3: reflexivity.
+  exact (ap S (IHn _)).
+Defined.
+
+(** The maximum of [n.+1] and [n] is [n.+1]. *)
+Definition nat_max_succ_l@{} n : nat_max n.+1 n = n.+1.
+Proof.
+  simple_induction' n; cbn.
+  1: reflexivity.
+  exact (ap S IH).
+Defined.
+
+(** The maximum of [n] and [n.+1] is [n.+1]. *)
+Definition nat_max_succ_r@{} n : nat_max n n.+1 = n.+1
+  := nat_max_comm _ _ @ nat_max_succ_l _.
+
+(** [0] is the left identity of [nat_max]. *)
+Definition nat_max_zero_l@{} n : nat_max 0 n = n := idpath.
+
+(** [0] is the right identity of [nat_max]. *)
+Definition nat_max_zero_r@{} n : nat_max n 0 = n
+  := nat_max_comm _ _ @ nat_max_zero_l _.
+
+(** [nat_max n m] is [n] if [m <= n]. *)
+Definition nat_max_l@{} {n m} : m <= n -> nat_max n m = n.
+Proof.
+  intros H.
+  induction m as [|m IHm] in n, H |- *.
+  1: nrapply nat_max_zero_r.
+  destruct n.
+  1: inversion H.
+  cbn; by apply (ap S), IHm, leq_pred'.
 Defined.
 
-Theorem max_r : forall n m : nat, n <= m -> max n m = m.
+(** [nat_max n m] is [m] if [n <= m]. *)
+Definition nat_max_r {n m} : n <= m -> nat_max n m = m
+  := fun _ => nat_max_comm _ _ @ nat_max_l _.
+
+(** [nat_max n m] is associative. *)
+Definition nat_max_assoc@{} n m k
+  : nat_max n (nat_max m k) = nat_max (nat_max n m) k.
 Proof.
-  intros; rewrite max_comm; by apply max_l.
+  induction n as [|n IHn] in m, k |- *.
+  1: reflexivity.
+  destruct m, k.
+  1-3: reflexivity.
+  by apply (ap S), IHn.
 Defined.
 
-Lemma min_comm : forall n m, min n m = min m n.
+(** Properties of Minima *)
+
+(** [nat_min] is idempotent. *)
+Definition nat_min_idem n : nat_min n n = n.
 Proof.
-  simple_induction' n; destruct m; cbn; auto.
+  simple_induction' n; cbn.
+  1: reflexivity.
+  exact (ap S IH).
 Defined.
 
-Theorem min_l : forall n m : nat, n <= m -> min n m = n.
+(** [nat_min] is commutative. *)
+Definition nat_min_comm n m : nat_min n m = nat_min m n.
 Proof.
+  induction n as [|n IHn] in m |- *; destruct m; cbn.
+  1-3: reflexivity.
+  exact (ap S (IHn _)).
+Defined.
+
+(** [nat_min] of [0] and [n] is [0]. *)
+Definition nat_min_zero_l n : nat_min 0 n = 0 := idpath.
+
+(** [nat_min] of [n] and [0] is [0]. *)
+Definition nat_min_zero_r n : nat_min n 0 = 0:=
+  nat_min_comm _ _ @ nat_min_zero_l _.
+
+(** [nat_min n m] is [n] if [n <= m]. *)
+Definition nat_min_l {n m} : n <= m -> nat_min n m = n.
+Proof.
+  revert n m.
   simple_induction n n IHn; auto.
   intros [] p.
   1: inversion p.
-  cbn; by apply ap_S, IHn, leq_S_n.
+  cbn; by apply (ap S), IHn, leq_pred'.
 Defined.
 
-Theorem min_r : forall n m : nat, m <= n -> min n m = m.
+(** [nat_min n m] is [m] if [m <= n]. *)
+Definition nat_min_r {n m} : m <= n -> nat_min n m = m
+  := fun _ => nat_min_comm _ _ @ nat_min_l _.
+
+(** [nat_min n m] is associative. *)
+Definition nat_min_assoc n m k
+  : nat_min n (nat_min m k) = nat_min (nat_min n m) k.
 Proof.
-  intros; rewrite min_comm; by apply min_l.
+  induction n as [|n IHn] in m, k |- *.
+  1: reflexivity.
+  destruct m, k.
+  1-3: reflexivity.
+  by apply (ap S), IHn.
 Defined.
 
-(** [n]th iteration of the function [f : A -> A].  We have definitional equalities [nat_iter 0 f x = x] and [nat_iter n.+1 f x = f (nat_iter n f x)].  We make this a notation, so it doesn't add a universe variable for the universe containing [A]. *)
-Notation nat_iter n f x
-  := ((fix F (m : nat)
-      := match m with
-        | 0 => x
-        | m'.+1 => f (F m')
-        end) n).
+(** ** More theory of comparison predicates *)
 
-Lemma nat_iter_succ_r n {A} (f : A -> A) (x : A)
-  : nat_iter (S n) f x = nat_iter n f (f x).
+(** *** Addition lemmas *)
+
+(** The second summand is less than or equal to the sum. *)
+Global Instance leq_add_l n m : n <= m + n.
 Proof.
-  simple_induction n n IHn; simpl; trivial.
-  exact (ap f IHn).
+  simple_induction m m IH.
+  - exact (leq_refl n).
+  - exact (leq_succ_r IH).
 Defined.
 
-Theorem nat_iter_add (n m : nat) {A} (f : A -> A) (x : A)
-  : nat_iter (n + m) f x = nat_iter n f (nat_iter m f x).
+(** The first summand is less than or equal to the sum. *)
+Global Instance leq_add_r n m : n <= n + m.
 Proof.
-  simple_induction n n IHn; simpl; trivial.
-  exact (ap f IHn).
+  simple_induction n n IHn.
+  - exact (leq_zero_l m).
+  - exact (leq_succ IHn).
 Defined.
 
-(** Preservation of invariants : if [f : A -> A] preserves the invariant [P], then the iterates of [f] also preserve it. *)
-Theorem nat_iter_invariant (n : nat) {A} (f : A -> A) (P : A -> Type)
-  : (forall x, P x -> P (f x)) -> forall x, P x -> P (nat_iter n f x).
+(** *** Multiplication lemmas *)
+
+(** The second multiplicand is less than or equal to the product. *)
+Global Instance leq_mul_l n m l : l < m -> n <= m * n.
 Proof.
-  simple_induction n n IHn; simpl; trivial.
-  intros Hf x Hx.
-  apply Hf, IHn; trivial.
+  intros H; induction H; exact _.
+Defined.
+
+(** The first multiplicand is less than or equal to the product. *)
+Global Instance leq_mul_r n m l : l < m -> n <= n * m.
+Proof.
+  rewrite nat_mul_comm; exact _.
 Defined.
 
-(** ** Arithmetic *)
+(** ** Eliminating positive assumptions *)
 
-Lemma nat_add_n_Sm (n m : nat) : (n + m).+1 = n + m.+1.
+(** Sometimes we want to prove a predicate which assumes that [0 < x]. In that case, it suffices to prove it for [x.+1] instead. *)
+Definition gt_zero_ind (P : nat -> Type)
+  (H : forall x, P x.+1)
+  : forall x (l : 0 < x), P x.
 Proof.
-  simple_induction' n; simpl.
+  intros x l.
+  destruct x.
+  1: contradiction (lt_irrefl _ l).
+  apply H.
+Defined.
+
+(** Alternative Characterizations of [<=] *)
+
+(** [n <= m] is equivalent to [(n < m) + (n = m)]. This justifies the name "less than or equal to". Note that it is not immediately obvious that the latter type is a hprop. *)
+Definition equiv_leq_lt_or_eq {n m} : (n <= m) <~> (n < m) + (n = m).
+Proof.
+  srapply equiv_iff_hprop.
+  - nrapply ishprop_sum.
+    1,2: exact _.
+    intros H1 p; destruct p.
+    contradiction (lt_irrefl _ _).
+  - intro l; induction l.
+    + now right.
+    + left; exact (leq_succ l).
+  - intros [l|p].
+    + exact (leq_succ_l l).
+    + destruct p.
+      exact (leq_refl _).
+Defined.
+
+(** Here is an alternative characterization of [<=] in terms of an existence predicate and addition. *)
+Definition equiv_leq_add n m : n <= m <~> exists k, k + n = m.
+Proof.
+  srapply equiv_iff_hprop.
+  - apply hprop_allpath.
+    intros [x p] [y q].
+    pose (r := nat_moveL_nV _ p @ (nat_moveL_nV _ q)^).
+    destruct r.
+    apply ap.
+    apply path_ishprop.
+  - intros p.
+    exists (m - n).
+    apply nat_add_sub_l_cancel, p.
+  - intros [k p].
+    destruct p.
+    apply leq_add_l.
+Defined.
+
+(** *** Dichotomy of [<=] *)
+
+Definition leq_dichotomy m n : (m <= n) + (m > n).
+Proof.
+  induction m as [|m IHm] in n |- *.
+  1: left; exact _.
+  destruct n.
+  1: right; exact _.
+  destruct (IHm n).
+  1: left; exact _.
+  1: right; exact _.
+Defined.
+
+(** *** Trichotomy *)
+
+(** Any two natural numbers are either equal, less than, or greater than each other. *)
+Definition nat_trichotomy m n : (m < n) + (m = n) + (m > n).
+Proof.
+  generalize (leq_dichotomy m n).
+  snrapply (functor_sum _ idmap).
+  snrapply equiv_leq_lt_or_eq.
+Defined.
+
+(** *** Negation lemmas *)
+
+(** There are various lemmas we can state about negating the comparison operators on [nat]. To aid readability, we opt to keep the order of the variables in each statement consistent. *)
+
+Definition geq_iff_not_lt {n m} : ~(n < m) <-> n >= m.
+Proof.
+  split.
+  - intro; by destruct (leq_dichotomy m n).
+  - intros ? ?; contradiction (lt_irrefl n); exact _.
+Defined.
+
+Definition gt_iff_not_leq {n m} : ~(n <= m) <-> n > m.
+Proof.
+  split.
+  - intro; by destruct (leq_dichotomy n m).
+  - intros ? ?; contradiction (lt_irrefl m); exact _.
+Defined.
+
+Definition leq_iff_not_gt {n m} : ~(n > m) <-> n <= m
+  := geq_iff_not_lt.
+
+Definition lt_iff_not_geq {n m} : ~(n >= m) <-> n < m
+  := gt_iff_not_leq.
+
+(** *** Dichotomy of [<>] *)
+
+(** The inequality of natural numbers is equivalent to [n < m] or [n > m]. This could be an equivalence however one of the sections requires funext since we are comparing two inequality proofs. It is therefore more useful to keep it as a biimplication. Note that this is a negated version of antisymmetry of [<=]. *)
+Definition neq_iff_lt_or_gt {n m} : n <> m <-> (n < m) + (n > m).
+Proof.
+  split.
+  - intros diseq.
+    destruct (dec (n < m)) as [| a]; [ now left |].
+    apply geq_iff_not_lt in a.
+    apply equiv_leq_lt_or_eq in a.
+    destruct a as [lt | eq].
+    1: by right.
+    symmetry in eq.
+    contradiction.
+  - intros [H' | H'] nq; destruct nq; exact (lt_irrefl _ H').
+Defined.
+
+(** ** Arithmetic relations between [trunc_index] and [nat]. *)
+
+Definition trunc_index_add_nat_add {n : nat}: trunc_index_add n n = n.+1 + n.+1.
+Proof.
+  induction n as [|n IHn].
+  1: reflexivity.
+  lhs nrapply trunc_index_add_succ.
+  rhs nrapply (ap nat_to_trunc_index).
+  2: nrapply nat_add_succ_r.
+  exact (ap (fun x => x.+2%trunc) IHn).
+Defined.
+
+(** *** Subtraction *)
+
+Global Instance leq_sub_add_l n m : n <= n - m + m.
+Proof.
+  destruct (@leq_dichotomy m n) as [l | g].
+  - by rewrite nat_add_sub_l_cancel.
+  - apply leq_lt in g.
+    by destruct (equiv_nat_sub_leq _)^.
+Defined.
+
+Global Instance leq_sub_add_r n m : n <= m + (n - m).
+Proof.
+  rewrite nat_add_comm; exact _.
+Defined.
+
+(** A number being less than another is equivalent to their difference being greater than zero. *)
+Definition equiv_lt_lt_sub n m : m < n <~> 0 < n - m.
+Proof.
+  induction n as [|n IHn] in m |- *.
+  1: srapply equiv_iff_hprop; intro; contradiction (not_lt_zero_r _ _).
+  destruct m; only 1: reflexivity.
+  nrefine (IHn m oE _).
+  srapply equiv_iff_hprop.
+Defined.
+
+(** *** Monotonicity of addition *)
+
+(** TODO: use OrderPreserving from canonical_names *)
+
+(** Addition on the left is monotone. *)
+Definition nat_add_l_monotone {n m} k
+  : n <= m -> k + n <= k + m.
+Proof.
+  intros H; induction k; exact _.
+Defined.
+Hint Immediate nat_add_l_monotone : typeclass_instances.
+
+(** Addition on the right is monotone. *)
+Definition nat_add_r_monotone {n m} k
+  : n <= m -> n + k <= m + k.
+Proof.
+  intros H; rewrite 2 (nat_add_comm _ k); exact _.
+Defined.
+Hint Immediate nat_add_r_monotone : typeclass_instances.
+
+(** Addition is monotone in both arguments. (This makes [+] a bifunctor when treating [nat] as a category (as a preorder)). *)
+Definition nat_add_monotone {n n' m m'}
+  : n <= m -> n' <= m' -> n + n' <= m + m'.
+Proof.
+  intros H1 H2; induction H1; exact _.
+Defined.
+Hint Immediate nat_add_monotone : typeclass_instances.
+
+(** *** Strict monotonicity of addition *)
+
+(** [nat_succ] is strictly monotone. *)
+Global Instance lt_succ {n m} : n < m -> n.+1 < m.+1 := _.
+
+Global Instance lt_succ_r {n m} : n < m -> n < m.+1 := _.
+
+(** Addition on the left is strictly monotone. *)
+Definition nat_add_l_strictly_monotone {n m} k
+  : n < m -> k + n < k + m.
+Proof.
+  intros H; induction k; exact _.
+Defined.
+Hint Immediate nat_add_l_strictly_monotone : typeclass_instances.
+
+(** Addition on the right is strictly monotone. *)
+Definition nat_add_r_strictly_monotone {n m} k
+  : n < m -> n + k < m + k.
+Proof.
+  intros H; rewrite 2 (nat_add_comm _ k); exact _.
+Defined.
+Hint Immediate nat_add_r_strictly_monotone : typeclass_instances.
+
+(** Addition is strictly monotone in both arguments. *)
+Definition nat_add_strictly_monotone {n n' m m'}
+  : n < m -> n' < m' -> n + n' < m + m'.
+Proof.
+  intros H1 H2; induction H1; exact _.
+Defined.
+Hint Immediate nat_add_strictly_monotone : typeclass_instances.
+
+(** *** Monotonicity of multiplication *)
+
+(** Multiplication on the left is monotone. *)
+Definition nat_mul_l_monotone {n m} k
+  : n <= m -> k * n <= k * m.
+Proof.
+  intros H; induction k; exact _.
+Defined.
+Hint Immediate nat_mul_l_monotone : typeclass_instances.
+
+(** Multiplication on the right is monotone. *)
+Definition nat_mul_r_monotone {n m} k
+  : n <= m -> n * k <= m * k.
+Proof.
+  intros H; rewrite 2 (nat_mul_comm _ k); exact _.
+Defined.
+Hint Immediate nat_mul_r_monotone : typeclass_instances.
+
+(** Multiplication is monotone in both arguments. *)
+Definition nat_mul_monotone {n n' m m'}
+  : n <= m -> n' <= m' -> n * n' <= m * m'.
+Proof.
+  intros H1 H2; induction H1; exact _.
+Defined.
+Hint Immediate nat_mul_monotone : typeclass_instances.
+
+(** *** Strict monotonicity of multiplication *)
+
+(** Multiplication on the left by a positive number is strictly monotone. *)
+Definition nat_mul_l_strictly_monotone {n m l} k
+  : l < k -> n < m -> k * n < k * m.
+Proof.
+  destruct k.
+  1: intro; contradiction (not_lt_zero_r _ H).
+  intros _ H; induction k as [|k IHk] in |- *; exact _.
+Defined.
+Hint Immediate nat_mul_l_strictly_monotone : typeclass_instances.
+
+(** Multiplication on the right by a positive number is strictly monotone. *)
+Definition nat_mul_r_strictly_monotone {n m l} k
+  : l < k -> n < m -> n * k < m * k.
+Proof.
+  intros ? H; rewrite 2 (nat_mul_comm _ k); exact _.
+Defined.
+Hint Immediate nat_mul_r_strictly_monotone : typeclass_instances.
+
+(** Multiplication is strictly monotone in both arguments. *)
+Definition nat_mul_strictly_monotone {n n' m m'}
+  : n < m -> n' < m' -> n * n' < m * m'.
+Proof.
+  intros H1 H2.
+  nrapply (lt_leq_lt_trans (m:=n * m')).
+  1: rapply nat_mul_l_monotone.
+  rapply nat_mul_r_strictly_monotone.
+Defined.
+Hint Immediate nat_mul_strictly_monotone : typeclass_instances.
+
+(** *** Order-reflection *)
+
+(** Addition on the left is order-reflecting. *)
+Definition leq_reflects_add_l {n m} k : k + n <= k + m -> n <= m.
+Proof.
+  intros H; induction k; exact _.
+Defined.
+
+(** Addition on the right is order-reflecting. *)
+Definition leq_reflects_add_r {n m} k : n + k <= m + k -> n <= m.
+Proof.
+  rewrite 2 (nat_add_comm _ k); nrapply leq_reflects_add_l.
+Defined.
+
+(** Addition on the left is strictly order-reflecting. *)
+Definition lt_reflects_add_l {n m} k : k + n < k + m -> n < m.
+Proof.
+  intros H; induction k; exact _.
+Defined.
+
+(** Addition on the right is strictly order-reflecting. *)
+Definition lt_reflects_add_r {n m} k : n + k < m + k -> n < m.
+Proof.
+  rewrite 2 (nat_add_comm _ k); nrapply lt_reflects_add_l.
+Defined.
+
+(** ** Further properties of subtraction *)
+
+Global Instance leq_sub_l n m : n - m <= n.
+Proof.
+  apply equiv_nat_sub_leq.
+  rewrite nat_sub_comm_r.
+  rewrite nat_sub_cancel.
+  apply nat_sub_zero_l.
+Defined.
+
+(** Subtracting from a successor is the successor of subtracting from the original number, as long as the amount being subtracted is less than or equal to the original number. *)
+Definition nat_sub_succ_l n m : m <= n -> n.+1 - m = (n - m).+1.
+Proof.
+  intros H.
+  induction m as [|m IHm] in n, H |- *.
+  - by rewrite 2 nat_sub_zero_r.
+  - simpl.
+    rewrite nat_sub_succ_r.
+    symmetry.
+    apply nat_succ_pred.
+    by apply equiv_lt_lt_sub.
+Defined.
+
+(** Under certain conditions, subtracting a predecessor is the successor of the subtraction. *)
+Definition nat_sub_pred_r n m : 0 < m -> m < n -> n - nat_pred m = (n - m).+1.
+Proof.
+  revert m; snrapply gt_zero_ind.
+  intros m H1.
+  rewrite nat_sub_succ_r.
+  rewrite nat_succ_pred.
+  1: reflexivity.
+  apply equiv_lt_lt_sub.
+  exact (lt_trans _ H1).
+Defined.
+
+(** Subtracting from a sum is the sum of subtracting from the second summand. *)
+Definition nat_sub_l_add_r m n k
+  : k <= m -> (n + m) - k = n + (m - k).
+Proof.
+  intros H; induction n as [|n IHn] in |- *.
   - reflexivity.
-  - apply ap; assumption.
+  - change (?n.+1 + ?m) with (n + m).+1.
+    lhs nrapply nat_sub_succ_l.
+    2: exact (ap nat_succ IHn).
+    exact _.
 Defined.
 
-Definition nat_add_comm (n m : nat) : n + m = m + n.
+(** Subtracting from a sum is the sum of subtracting from the first summand. *)
+Definition nat_sub_l_add_l n m k
+  : k <= n -> (n + m) - k = (n - k) + m.
 Proof.
-  simple_induction n n IHn; simpl.
-  - exact (add_n_O m).
-  - transitivity (m + n).+1.
-    + apply ap, IHn.
-    + apply nat_add_n_Sm.
+  intro l.
+  rewrite nat_add_comm.
+  lhs rapply nat_sub_l_add_r.
+  apply nat_add_comm.
 Defined.
 
-(** ** Exponentiation *)
+(** Subtracting a subtraction is the subtrahend. *)
+Definition nat_sub_sub_cancel_r {n m} : n <= m -> m - (m - n) = n.
+Proof.
+  intros H; induction H.
+  - by rewrite nat_sub_cancel, nat_sub_zero_r.
+  - rewrite (nat_sub_succ_l m n); only 2: exact _.
+    exact IHleq.
+Defined.
 
-Fixpoint nat_exp (n m : nat) : nat
-  := match m with
-       | 0 => 1
-       | S m => nat_exp n m * n
-     end.
+(** Multiplication on the left distributes over subtraction. *)
+Definition nat_dist_sub_l n m k
+  : n * (m - k) = n * m - n * k.
+Proof.
+  induction n as [|n IHn] in m, k |- *.
+  1: reflexivity.
+  destruct (leq_dichotomy k m) as [l|r].
+  - simpl; rewrite IHn, <- nat_sub_l_add_r, <- nat_sub_l_add_l,
+      nat_sub_r_add; trivial; exact _.
+  - apply leq_lt in r.
+    apply equiv_nat_sub_leq in r.
+    rewrite r.
+    rewrite nat_mul_zero_r.
+    symmetry.
+    apply equiv_nat_sub_leq.
+    apply nat_mul_l_monotone.
+    by apply equiv_nat_sub_leq.
+Defined.
+
+(** Multiplication on the right distributes over subtraction. *)
+Definition nat_dist_sub_r n m k
+  : (n - m) * k = n * k - m * k.
+Proof.
+  rewrite 3 (nat_mul_comm _ k).
+  apply nat_dist_sub_l.
+Defined.
 
-(** ** Factorials *)
+(** *** Monotonicity of subtraction *)
 
-Fixpoint factorial (n : nat) : nat
-  := match n with
-       | 0 => 1
-       | S n => S n * factorial n
-     end.
+(** Subtraction is monotone in the left argument. *)
+Definition nat_sub_monotone_l {n m} k : n <= m -> n - k <= m - k.
+Proof.
+  intros H.
+  destruct (leq_dichotomy k n) as [l|r].
+  - apply (leq_reflects_add_l k).
+    rewrite 2 nat_add_sub_r_cancel.
+    + exact H.
+    + rapply leq_trans.
+    + exact l.
+  - apply leq_succ_l in r.
+    apply equiv_nat_sub_leq in r.
+    destruct r^.
+    exact _.
+Defined.
+Hint Immediate nat_sub_monotone_l : typeclass_instances.
 
-(** ** Natural number ordering *)
+(** Subtraction is contravariantly monotone in the right argument. *)
+Definition nat_sub_monotone_r {n m} k : n <= m -> k - m <= k - n.
+Proof.
+  intros H.
+  induction k.
+  - by rewrite nat_sub_zero_l.
+  - destruct (leq_dichotomy m k) as [l|r].
+    + rewrite 2 nat_sub_succ_l; exact _.
+    + apply equiv_nat_sub_leq in r.
+      destruct r^.
+      exact _.
+Defined.
+Hint Immediate nat_sub_monotone_r : typeclass_instances.
 
-(** ** Theorems about natural number ordering *)
+(** *** Order-reflection lemmas *)
 
-Lemma leq_antisym {x y} : x <= y -> y <= x -> x = y.
+(** Subtraction reflects [<=] in the left argument. *)
+Definition leq_reflects_sub_l {n m} k : k <= m -> n - k <= m - k -> n <= m.
 Proof.
-  intros p q.
-  destruct p.
+  intros ineq1 ineq2.
+  apply (nat_add_r_monotone k) in ineq2.
+  apply (@leq_trans _ (n - k + k) _ (leq_sub_add_l _ _)).
+  apply (@leq_trans _ (m - k + k) _ _).
+  by rewrite nat_add_sub_l_cancel.
+Defined.
+
+(** Subtraction reflects [<=] in the right argument contravariantly. *)
+Definition leq_reflects_sub_r {n m} k
+  : m <= k -> n <= k -> k - n <= k - m -> m <= n.
+Proof.
+  intros H1 H2 H3.
+  apply (nat_sub_monotone_r k) in H3.
+  rewrite 2 nat_sub_sub_cancel_r in H3; exact _.
+Defined.
+
+(** *** Movement lemmas *)
+
+(** Given an inequality [n < m] we can move around a summand or subtrahend [k] from either side. *)
+
+Definition leq_moveL_Mn {n m} k : n - k <= m -> n <= k + m.
+Proof.
+  intros H.
+  rewrite nat_add_comm.
+  apply (nat_add_r_monotone k) in H.
+  rapply leq_trans.
+Defined.
+
+Definition leq_moveL_nM {n m} k : n - k <= m -> n <= m + k.
+Proof.
+  rewrite nat_add_comm.
+  apply leq_moveL_Mn.
+Defined.
+
+Definition leq_moveR_Mn {n m} k : k <= m -> n <= m - k -> k + n <= m.
+Proof.
+  intros H1 H2.
+  rapply (leq_reflects_sub_l k).
+  by rewrite nat_add_sub_cancel_l.
+Defined.
+
+Definition leq_moveR_nM {n m} k : k <= m -> n <= m - k -> n + k <= m.
+Proof.
+  rewrite nat_add_comm.
+  apply leq_moveR_Mn.
+Defined.
+
+Definition leq_moveL_nV {n m} k : n + k <= m -> n <= m - k.
+Proof.
+  intros H.
+  apply (leq_reflects_add_r k).
+  rapply leq_trans.
+Defined.
+
+Definition leq_moveR_nV {n m} k : n <= m + k -> n - k <= m.
+Proof.
+  intros H.
+  apply (nat_sub_monotone_l k) in H.
+  by rewrite nat_add_sub_cancel_r in H.
+Defined.
+
+Definition lt_moveL_Mn {n m} k : n - k < m -> n < k + m.
+Proof.
+  intros H.
+  apply (nat_add_l_strictly_monotone k) in H.
+  rapply lt_leq_lt_trans.
+Defined.
+
+Definition lt_moveL_nM {n m} k : n - k < m -> n < m + k.
+Proof.
+  rewrite nat_add_comm.
+  apply lt_moveL_Mn.
+Defined.
+
+Definition lt_moveR_Mn {n m} k : k < m -> n < m - k -> k + n < m.
+Proof.
+  intros H1 H2.
+  rewrite nat_add_comm.
+  rapply (leq_moveR_nM (n:=n.+1) k).
+Defined.
+
+Definition lt_moveR_nM {n m} k : k < m -> n < m - k -> n + k < m.
+Proof.
+  rewrite nat_add_comm.
+  apply lt_moveR_Mn.
+Defined.
+
+Definition lt_moveL_nV {n m} k : n + k < m -> n < m - k.
+Proof.
+  intros H.
+  rapply leq_moveL_nV.
+Defined.
+
+Definition lt_moveR_nV {n m} k : k <= n -> n < k + m -> n - k < m.
+Proof.
+  intros H1 H2; unfold lt.
+  rewrite <- nat_sub_succ_l; only 2: exact _.
+  rewrite <- (nat_add_sub_cancel_l m k).
+  by apply nat_sub_monotone_l.
+Defined.
+
+(** ** Properties of powers *)
+
+(** [0] to any power is [0] unless that power is [0] in which case it is [1]. *)
+Definition nat_pow_zero_l@{} n : nat_pow 0 n = if dec (n = 0) then 1 else 0.
+Proof.
+  destruct n; reflexivity.
+Defined.
+
+(** Any number to the power of [0] is [1]. *)
+Definition nat_pow_zero_r@{} n : nat_pow n 0 = 1
+  := idpath.
+
+(** [1] to any power is [1]. *)
+Definition nat_pow_one_l@{} n : nat_pow 1 n = 1.
+Proof.
+  induction n as [|n IHn]; simpl.
   1: reflexivity.
-  destruct x; [inversion q|].
-  apply leq_S_n in q.
-  pose (r := leq_trans p q).
-  by apply not_leq_Sn_n in r.
+  lhs nrapply nat_add_zero_r.
+  exact IHn.
 Defined.
 
-Definition not_lt_n_n n : ~ (n < n) := not_leq_Sn_n n.
+(** Any number to the power of [1] is itself. *)
+Definition nat_pow_one_r@{} n : nat_pow n 1 = n
+  := nat_mul_one_r _.
 
-Definition leq_1_Sn {n} : 1 <= n.+1 := leq_S_n' 0 n (leq_0_n _).
+(** Exponentiation of natural numbers is distributive over addition on the left. *)
+Definition nat_pow_add_r@{} n m k
+  : nat_pow n (m + k) = nat_pow n m * nat_pow n k.
+Proof.
+  induction m as [|m IHm]; simpl.
+  - symmetry.
+    apply nat_add_zero_r.
+  - rhs_V nrapply nat_mul_assoc.
+    exact (ap _ IHm).
+Defined.
 
-Fixpoint leq_dichot {m} {n} : (m <= n) + (m > n).
+(** Exponentiation of natural numbers is distributive over multiplication on the right. *)
+Definition nat_pow_mul_l@{} n m k
+  : nat_pow (n * m) k = nat_pow n k * nat_pow m k.
 Proof.
-  simple_induction' m; simple_induction' n.
-  - left; reflexivity.
-  - left; apply leq_0_n.
-  - right; unfold lt; apply leq_1_Sn.
-  - assert ((m <= n) + (n < m)) as X by apply leq_dichot.
-    destruct X as [leqmn|ltnm].
-    + left; apply leq_S_n'; assumption.
-    + right; apply leq_S_n'; assumption.
+  induction k as [|k IHk]; simpl.
+  1: reflexivity.
+  lhs_V nrapply nat_mul_assoc.
+  rhs_V nrapply nat_mul_assoc.
+  nrapply ap.
+  rhs nrapply nat_mul_comm.
+  rhs_V nrapply nat_mul_assoc.
+  nrapply ap.
+  rhs nrapply nat_mul_comm.
+  exact IHk.
 Defined.
 
-Lemma not_lt_n_0 n : ~ (n < 0).
+(** Exponentiation of natural numbers is distributive over multiplication on the left. *)
+Definition nat_pow_mul_r@{} n m k
+  : nat_pow n (m * k) = nat_pow (nat_pow n m) k.
 Proof.
-  apply not_leq_Sn_0.
+  induction m as [|m IHm]; simpl.
+  - exact (nat_pow_one_l _)^.
+  - lhs nrapply nat_pow_add_r.
+    rhs nrapply nat_pow_mul_l.
+    nrapply ap.
+    exact IHm.
 Defined.
 
-(** ** Arithmetic relations between [trunc_index] and [nat]. *)
+(** *** Monotonicity of powers *)
 
-Lemma trunc_index_add_nat_add (n : nat)
-  : trunc_index_add n n = n.+1 + n.+1.
-Proof.
-  induction n as [|n IH]; only 1: reflexivity.
-  refine (trunc_index_add_succ _ _ @ _).
-  refine (ap trunc_S _ @ _).
-  { refine (trunc_index_add_comm _ _ @ _).
-    refine (trunc_index_add_succ _ _ @ _).
-    exact (ap trunc_S IH). }
-  refine (_ @ ap nat_to_trunc_index _).
-  2: exact (ap _ (add_Sn_m _ _)^ @ add_n_Sm _ _).
-  reflexivity.
+Definition nat_pow_l_monotone {n m} k
+  : n <= m -> nat_pow k.+1 n <= nat_pow k.+1 m.
+Proof.
+  intros H; induction H; exact _.
+Defined.
+
+Definition nat_pow_r_monotone {n m} k
+  : n <= m -> nat_pow n k <= nat_pow m k.
+Proof.
+  intros H; induction k; exact _.
+Defined.
+
+(** ** Strong induction *)
+
+(** Sometimes using [nat_ind] is not sufficient to prove a statement as it may be difficult to prove [P n -> P n.+1]. We can strengthen the induction hypothesis by assuming that [P m] holds for all [m] less than [n]. This is known as strong induction. *)
+Definition nat_ind_strong@{u} (P : nat -> Type@{u})
+  (IH_strong : forall n, (forall m, m < n -> P m) -> P n)
+  : forall n, P n.
+Proof.
+  intros n.
+  apply IH_strong.
+  simple_induction n n IHn; intros m H.
+  1: contradiction (not_lt_zero_r m).
+  apply leq_pred' in H.
+  apply equiv_leq_lt_or_eq in H.
+  destruct H as [H|p].
+  - by apply IHn.
+  - destruct p.
+    by apply IH_strong.
+Defined.
+
+(** ** An induction principle for two variables with a constraint. *)
+Definition nat_double_ind_leq@{u} (P : nat -> nat -> Type@{u})
+  (Hn0 : forall n, P n 0)
+  (Hnn : forall n, P n n)
+  (IH : forall n m, m < n -> (forall m', m' <= n -> P n m') -> P n.+1 m.+1)
+  : forall n m, m <= n -> P n m.
+Proof.
+  intro n; simple_induction n n IHn; intros m H.
+  - destruct (path_zero_leq_zero_r m H)^; clear H.
+    apply Hn0.
+  - destruct m.
+    + apply Hn0.
+    + apply equiv_leq_lt_or_eq in H.
+      destruct H as [H | []].
+      2: apply Hnn.
+      rapply IH.
+      rapply IHn.
 Defined.
diff --git a/theories/Spaces/Nat/Division.v b/theories/Spaces/Nat/Division.v
new file mode 100644
index 00000000000..7e8f888f247
--- /dev/null
+++ b/theories/Spaces/Nat/Division.v
@@ -0,0 +1,1197 @@
+Require Import Basics.Overture Basics.Tactics Basics.Trunc Basics.Classes
+  Basics.PathGroupoids Basics.Equivalences Types.Sigma Spaces.Nat.Core
+  Basics.Decidable Basics.Iff Types.Prod List.Theory Types.Sum Types.Arrow.
+
+Local Set Universe Minimization ToSet.
+Local Open Scope nat_scope.
+
+(** * Division of natural numbers *)
+
+(** ** Divisibility *)
+
+(** We define divisibility as a relation between natural numbers. *)
+Class NatDivides (n m : nat) : Type0 := nat_divides : {k : nat & k * n = m}.
+
+Notation "( n | m )" := (NatDivides n m) : nat_scope.
+
+(** Any number divides [0]. *)
+Global Instance nat_divides_zero_r n : (n | 0)
+  := (0; idpath).
+
+(** [1] divides any number. *)
+Global Instance nat_divides_one_l n : (1 | n)
+  := (n; nat_mul_one_r _).
+
+(** Any number divides itself. Divisibility is a reflexive relation. *)
+Global Instance nat_divides_refl n : (n | n)
+  := (1; nat_mul_one_l _).
+
+Global Instance reflexive_nat_divides : Reflexive NatDivides := nat_divides_refl.
+
+(** Divisibility is transitive. *)
+Definition nat_divides_trans {n m l} : (n | m) -> (m | l) -> (n | l).
+Proof.
+  intros [x p] [y q].
+  exists (y * x).
+  lhs_V nrapply nat_mul_assoc.
+  lhs nrapply (ap _ p).
+  exact q.
+Defined.
+Hint Immediate nat_divides_trans : typeclass_instances.
+
+Global Instance transitive_nat_divides : Transitive NatDivides := @nat_divides_trans.
+
+(** A left factor divides a product. *)
+Global Instance nat_divides_mul_l' n m : (n | n * m)
+  := (m; nat_mul_comm _ _).
+
+(** A right factor divides a product. *)
+Global Instance nat_divides_mul_r' n m : (m | n * m)
+  := (n; idpath).
+
+(** Divisibility of the product is implied by divisibility of the left factor. *)
+Global Instance nat_divides_mul_l {n m} l : (n | m) -> (n | m * l)
+  := fun H => nat_divides_trans _ _.
+
+(** Divisibility of the product is implied by divisibility of the right factor. *)
+Global Instance nat_divides_mul_r {n m} l : (n | m) -> (n | l * m)
+  := fun H => nat_divides_trans _ _.
+
+(** Multiplication is monotone with respect to divisibility. *)
+Global Instance nat_divides_mul_monotone n m l p
+  : (n | m) -> (l | p) -> (n * l | m * p).
+Proof.
+  intros [x r] [y q].
+  exists (x * y).
+  destruct r, q.
+  lhs nrapply nat_mul_assoc.
+  rhs nrapply nat_mul_assoc.
+  nrapply (ap (fun x => nat_mul x _)).
+  lhs_V nrapply nat_mul_assoc.
+  rhs_V nrapply nat_mul_assoc.
+  nrapply ap.
+  apply nat_mul_comm.
+Defined.
+
+(** Divisibility of the sum is implied by divisibility of the summands. *)
+Global Instance nat_divides_add n m l : (n | m) -> (n | l) -> (n | m + l).
+Proof.
+  intros [x p] [y q].
+  exists (x + y).
+  destruct p, q.
+  nrapply nat_dist_r.
+Defined.
+
+(** If [n] divides a sum and the left summand, then [n] divides the right summand. *)
+Definition nat_divides_add_r n m l : (n | m) -> (n | m + l) -> (n | l).
+Proof.
+  intros [x p] [y q].
+  exists (y - x).
+  lhs nrapply nat_dist_sub_r.
+  apply nat_moveR_nV.
+  lhs nrapply q.
+  lhs nrapply nat_add_comm.
+  exact (ap _ p^).
+Defined.
+
+(** If [n] divides a sum and the right summand, then [n] divides the left summand. *)
+Definition nat_divides_add_l n m l : (n | l) -> (n | m + l) -> (n | m).
+Proof.
+  rewrite nat_add_comm; apply nat_divides_add_r.
+Defined.
+
+(** Divisibility of the difference is implied by divisibility of the minuend and subtrahend. *)
+Global Instance nat_divides_sub n m l : (n | m) -> (n | l) -> (n | m - l).
+Proof.
+  intros [x p] [y q].
+  exists (x - y).
+  destruct p, q.
+  nrapply nat_dist_sub_r.
+Defined.
+
+(** The divisor is greater than zero when the divident is greater than zero. *)
+Definition gt_zero_divides n m (d : (n | m)) (gt0 : 0 < m)
+  : 0 < n.
+Proof.
+  destruct d as [d H].
+  destruct H.
+  destruct (nat_zero_or_gt_zero n) as [z | s].
+  2: exact s.
+  (* The remaining case is impossible. *)
+  destruct z; cbn in gt0.
+  rewrite nat_mul_zero_r in gt0.
+  exact gt0.
+Defined.
+
+(** Divisibility implies that the divisor is less than or equal to the dividend. *)
+Definition leq_divides n m : 0 < m -> (n | m) -> n <= m.
+Proof.
+  intros H1 [x p].
+  destruct p, x.
+  1: contradiction (not_lt_zero_r _ H1).
+  rapply (leq_mul_l _ _ 0).
+Defined.
+
+(** The divisor is strictly less than the dividend when the other factor is greater than one. *)
+Definition lt_divides n m (d : (n | m)) (gt0 : 0 < m) (gt1 : 1 < d.1)
+  : n < m.
+Proof.
+  rewrite <- d.2.
+  snrapply (lt_leq_lt_trans (m:=1*n)).
+  1: rapply (leq_mul_l _ _ 0).
+  srapply (nat_mul_r_strictly_monotone (l:=0)).
+  rapply (gt_zero_divides n m).
+Defined.
+
+(** Divisibility is antisymmetric *)
+Definition nat_divides_antisym n m : (n | m) -> (m | n) -> n = m.
+Proof.
+  intros H1 H2.
+  destruct m; only 1: exact (H2.2^ @ nat_mul_zero_r _).
+  destruct n; only 1: exact ((nat_mul_zero_r _)^ @ H1.2).
+  snrapply leq_antisym; nrapply leq_divides; exact _.
+Defined.
+
+Global Instance antisymmetric_divides : AntiSymmetric NatDivides
+  := nat_divides_antisym.
+
+(** If [n] divides [m], then the other factor also divides [m]. *)
+Global Instance divides_divisor n m (H : (n | m)) : (H.1 | m).
+Proof.
+  exists n.
+  lhs nrapply nat_mul_comm.
+  exact H.2.
+Defined.
+
+(** ** Properties of division *)
+
+Local Definition nat_div_mod_unique_helper b q1 q2 r1 r2
+  : r1 < b -> r2 < b -> q1 < q2 -> b * q1 + r1 <> b * q2 + r2.
+Proof.
+  intros H1 H2 H3 p.
+  rewrite 2 (nat_add_comm (b * _)) in p.
+  apply nat_moveL_nV in p.
+  rewrite nat_sub_l_add_r in p; only 2: rapply nat_mul_l_monotone.
+  rewrite <- nat_dist_sub_l in p.
+  rewrite nat_add_comm in p.
+  apply nat_moveR_nV in p.
+  nrapply (snd (@leq_iff_not_gt b (r1 - r2))).
+  2: exact (lt_leq_lt_trans _ H1).
+  rewrite p.
+  snrapply (leq_mul_r _ _ 0).
+  by apply equiv_lt_lt_sub.
+Defined.
+
+(** Quotients and remainders are uniquely determined. *)
+Definition nat_div_mod_unique d q1 q2 r1 r2
+  : r1 < d -> r2 < d -> d * q1 + r1 = d * q2 + r2
+    -> q1 = q2 /\ r1 = r2.
+Proof.
+  intros H1 H2 p.
+  destruct (nat_trichotomy q1 q2) as [[q | q] | q].
+  - contradiction (nat_div_mod_unique_helper d q1 q2 r1 r2).
+  - split; trivial.
+    destruct q.
+    by apply isinj_nat_add_l in p.
+  - by contradiction (nat_div_mod_unique_helper d q2 q1 r2 r1).
+Defined.
+
+(** Divisibility by a positive natural number is a hprop. *)
+Global Instance ishprop_nat_divides n m : 0 < n -> IsHProp (n | m).
+Proof.
+  intros H.
+  apply hprop_allpath.
+  intros [x p] [y q].
+  rapply path_sigma_hprop.
+  destruct H as [|n]; simpl.
+  1: exact ((nat_mul_one_r _)^ @ p @ q^ @ nat_mul_one_r _).
+  refine (fst (nat_div_mod_unique n.+1 x y 0 0 _ _ _)).
+  lhs nrapply nat_add_zero_r.
+  rhs nrapply nat_add_zero_r.
+  rewrite 2 (nat_mul_comm n.+1).
+  exact (p @ q^).
+Defined.
+
+(** This specifies the behaviour of [nat_div_mod_helper] when [u <= y]. *)
+Definition nat_div_mod_helper_spec x y q u (H : u <= y)
+  : let (q', u') := nat_div_mod x y q u in
+     x + y.+1 * q + (y - u) = y.+1 * q' + (y - u') /\ u' <= y.
+Proof.
+  intros d r.
+  induction x as [|x IHx] in y, q, u, H, d, r |- *; only 1: by split.
+  destruct u as [|u].
+  - destruct (IHx y q.+1 y _) as [p H'].
+    split; trivial.
+    rewrite <- p, nat_sub_zero_r, nat_sub_cancel, nat_add_zero_r.
+    simpl.
+    by rewrite nat_add_succ_r, <- 2 nat_add_assoc, nat_mul_succ_r.
+  - destruct (IHx y q u _) as [p H'].
+    split; trivial.
+    rewrite <- p, 2 nat_add_succ_l, <- nat_add_succ_r.
+    snrapply ap.
+    rewrite nat_sub_succ_r.
+    apply nat_succ_pred.
+    rapply lt_moveL_nV.
+Defined.
+
+(** Division and modulo can be put in quotient-remainder form. *)
+Definition nat_div_mod_spec x y : x = y * (x / y) + x mod y.
+Proof.
+  destruct y as [|y]; only 1: reflexivity.
+  pose proof (p := fst (nat_div_mod_helper_spec x y 0 y _)).
+  by rewrite nat_mul_zero_r, nat_sub_cancel, 2 nat_add_zero_r in p.
+Defined.
+
+Definition nat_div_mod_spec' x y : x - y * (x / y) = x mod y.
+Proof.
+  apply nat_moveR_nV.
+  rhs nrapply nat_add_comm.
+  apply nat_div_mod_spec.
+Defined.
+
+Definition nat_div_mod_spec'' x y : x - x mod y = y * (x / y).
+Proof.
+  apply nat_moveR_nV.
+  apply nat_div_mod_spec.
+Defined.
+
+Definition nat_mod_lt_r' n m r : r < m -> n mod m < m.
+Proof.
+  intros H; destruct H; only 1: exact _.
+  rapply (lt_leq_lt_trans (m:=m)).
+Defined.
+Hint Immediate nat_mod_lt_r' : typeclass_instances.
+
+(** [n] modulo [m] is less than [m]. *)
+Global Instance nat_mod_lt_r n m : 0 < m -> n mod m < m
+  := nat_mod_lt_r' n m 0.
+
+(** [n] modulo [m] is less than or equal to [m]. *)
+Global Instance nat_mod_leq_l n m : n mod m <= n.
+Proof.
+  rewrite <- nat_div_mod_spec'.
+  rapply leq_moveR_nV.
+Defined.
+
+(** Division is unique. *)
+Definition nat_div_unique x y q r (H : r < y) (p : y * q + r = x) : x / y = q
+  := fst (nat_div_mod_unique y (x / y) q (x mod y) r _ _ (p @ nat_div_mod_spec x y)^).
+
+(** Modulo is unique. *)
+Definition nat_mod_unique x y q r (H : r < y) (p : y * q + r = x) : x mod y = r
+  := snd (nat_div_mod_unique y (x / y) q (x mod y) r _ _ (p @ nat_div_mod_spec x y)^).
+
+(** [0] divided by any number is [0]. *)
+Definition nat_div_zero_l n : 0 / n = 0.
+Proof.
+  by induction n.
+Defined.
+
+(** [n] divided by [0] is [0] by convention. *)
+Definition nat_div_zero_r n : n / 0 = 0 := idpath.
+
+(** [n] divided by [1] is [n]. *)
+Definition nat_div_one_r n : n / 1 = n.
+Proof.
+  lhs_V nrapply nat_mul_one_l.
+  lhs_V nrapply nat_add_zero_r.
+  symmetry; apply nat_div_mod_spec.
+Defined.
+
+(** [n] divided by [n] is [1]. *)
+Definition nat_div_cancel n : 0 < n -> n / n = 1.
+Proof.
+  intros [|m _]; trivial.
+  nrapply (nat_div_unique _ _ _ 0); only 1: exact _.
+  lhs nrapply nat_add_zero_r.
+  nrapply nat_mul_one_r.
+Defined.
+
+(** A number divided by a larger number is 0. *)
+Definition nat_div_lt n m : n < m -> n / m = 0.
+Proof.
+  intros H.
+  snrapply (nat_div_unique _ _ _ _ H).
+  by rewrite nat_mul_zero_r, nat_add_zero_l.
+Defined.
+
+(** [n * m] divided by [n] is [m]. *)
+Definition nat_div_mul_cancel_l n m : 0 < n -> (n * m) / n = m.
+Proof.
+  intros H.
+  nrapply (nat_div_unique _ _ _ _ H).
+  apply nat_add_zero_r.
+Defined.
+
+(** [n * m] divided by [n] is [m]. *)
+Definition nat_div_mul_cancel_r n m : 0 < m -> (n * m) / m = n.
+Proof.
+  rewrite nat_mul_comm.
+  apply nat_div_mul_cancel_l.
+Defined.
+
+(** More generally, [n * m + k] divided by [n] is [m + k / n]. *)
+Definition nat_div_mul_add_cancel_l n m k : 0 < n -> (n * m + k) / n = m + k / n.
+Proof.
+  intros H.
+  rapply (nat_div_unique _ _ _ (k mod n) _).
+  rewrite nat_dist_l.
+  lhs_V nrapply nat_add_assoc.
+  f_ap.
+  symmetry; apply nat_div_mod_spec.
+Defined.
+
+Definition nat_div_mul_add_cancel_r n m k : 0 < m -> (n * m + k) / m = n + k / m.
+Proof.
+  rewrite nat_mul_comm.
+  apply nat_div_mul_add_cancel_l.
+Defined.
+
+(** If [k] is positive, then multiplication on the left is injective; that is, if [k * m = k * n], then [m = n]. *)
+Definition isinj_nat_mul_l k : 0 < k -> IsInjective (nat_mul k).
+Proof.
+  intros kp m n p.
+  lhs_V rapply (nat_div_mul_cancel_l k).
+  rhs_V rapply (nat_div_mul_cancel_l k).
+  exact (ap (fun x => x / k) p).
+Defined.
+
+(** If [k] is positive, then multiplication on the right is injective; that is, if [m * k = n * k], then [m = n]. *)
+Definition isinj_nat_mul_r k : 0 < k -> IsInjective (fun n => nat_mul n k).
+Proof.
+  intros kp m n p.
+  lhs_V rapply (nat_div_mul_cancel_r _ k).
+  rhs_V rapply (nat_div_mul_cancel_r _ k).
+  exact (ap (fun x => x / k) p).
+Defined.
+
+(** When [d] divides one of the summands, division distributes over addition. *)
+Definition nat_div_dist n m d
+  : (d | n) -> (n + m) / d = n / d + m / d.
+Proof.
+  destruct d.
+  1: reflexivity.
+  intros [x []].
+  rewrite nat_div_mul_cancel_r. 2: exact _.
+  rapply nat_div_mul_add_cancel_r.
+Defined.
+
+Definition nat_div_dist' n m d
+  : (d | m) -> (n + m) / d = n / d + m / d.
+Proof.
+  intros H.
+  rewrite (nat_add_comm n m).
+  rhs_V nrapply nat_add_comm.
+  rapply nat_div_dist.
+Defined.
+
+(** In general, [n * (m / n)] is less than or equal to [m]. *)
+Definition nat_leq_mul_div_l n m
+  : n * (m / n) <= m.
+Proof.
+  set (tmp := n * (m / n));
+    rewrite (nat_div_mod_spec m n);
+    unfold tmp; clear tmp.
+  exact _.
+Defined.
+
+(** When [n] divides [m], they are equal. *)
+Definition nat_mul_div_cancel_r n m
+  : (n | m) -> (m / n) * n = m.
+Proof.
+  destruct n.
+  { intros [k []]. cbn. symmetry; apply nat_mul_zero_r. }
+  intros [k []].
+  f_ap.
+  rapply nat_div_mul_cancel_r.
+Defined.
+
+Definition nat_mul_div_cancel_l n m
+  : (n | m) -> n * (m / n) = m.
+Proof.
+  rewrite nat_mul_comm.
+  apply nat_mul_div_cancel_r.
+Defined.
+
+(** Division by non-zero [k] is strictly monotone if [k] divides the larger number. *)
+Definition nat_div_strictly_monotone_r {n m l} k
+  : l < k -> n < m -> (k | m) -> n / k < m / k.
+Proof.
+  intros lk nm km.
+  apply gt_iff_not_leq.
+  intro mknk.
+  apply (@gt_iff_not_leq m n); only 1: apply nm.
+  rewrite <- (nat_mul_div_cancel_l k m km).
+  nrapply (leq_trans (y:=k * (n / k))).
+  - rapply nat_mul_l_monotone.
+  - apply nat_leq_mul_div_l.
+Defined.
+
+(** [0] modulo [n] is [0]. *)
+Definition nat_mod_zero_l n : 0 mod n = 0.
+Proof.
+  induction n; trivial.
+  apply nat_sub_cancel.
+Defined.
+
+(** [n] modulo [0] is [n]. *)
+Definition nat_mod_zero_r n : n mod 0 = n := idpath.
+
+(** TODO: generalise for all small n *)
+Definition nat_mod_one_l n : 1 < n -> 1 mod n = 1.
+Proof.
+  intros H.
+  destruct H; trivial.
+  destruct m.
+  1: contradiction (not_lt_zero_r _ H).
+  cbn; clear H.
+  by induction m.
+Defined.
+
+(** [n] modulo [1] is [0]. *)
+Definition nat_mod_one_r n : n mod 1 = 0.
+Proof.
+  by induction n.
+Defined.
+
+(** If [m] divides [n], then [n mod m = 0]. *)
+Definition nat_mod_divides n m : (m | n) -> n mod m = 0.
+Proof.
+  intros [x p].
+  destruct p.
+  destruct m.
+  { simpl. apply nat_mul_zero_r. }
+  lhs_V nrapply nat_div_mod_spec'.
+  rewrite nat_div_mul_cancel_r; only 2: exact _.
+  apply nat_moveR_nV, nat_mul_comm.
+Defined.
+
+(** [n mod m = 0] iff [m] divides [n]. *)
+Definition nat_mod_iff_divides n m : n mod m = 0 <-> (m | n) .
+Proof.
+  split.
+  2: exact (nat_mod_divides _ _).
+  intros p.
+  exists (n / m).
+  rewrite nat_mul_comm.
+  lhs_V nrapply nat_add_zero_r.
+  rewrite <- p.
+  symmetry.
+  nrapply nat_div_mod_spec.
+Defined.
+
+(** Divisibility is therefore decidable. *)
+Global Instance decidable_nat_divides n m : Decidable (n | m).
+Proof.
+  nrapply decidable_iff.
+  1: apply nat_mod_iff_divides.
+  exact _.
+Defined.
+
+(** [n] modulo [n] is [0]. *)
+Definition nat_mod_cancel n : n mod n = 0.
+Proof.
+  destruct n; trivial.
+  snrapply (nat_mod_unique _ _ 1); only 1: exact _.
+  lhs nrapply nat_add_zero_r.
+  nrapply nat_mul_one_r.
+Defined.
+
+(** A number can be corrected so that it is divisible by subtracting the modulo. *)
+Global Instance nat_divides_sub_mod n m : (n | m - m mod n).
+Proof.
+  rewrite nat_div_mod_spec''.
+  exact _.
+Defined.
+
+(** ** Further Properties of division and modulo *)
+
+(** We can cancel common factors on the left in a division. *)
+Definition nat_div_cancel_mul_l n m k
+  : 0 < k -> (k * n) / (k * m) = n / m.
+Proof.
+  intro kp.
+  destruct (nat_zero_or_gt_zero m) as [[] | mp].
+  1: by rewrite nat_mul_zero_r.
+  nrapply (nat_div_unique _ _ _ (k * (n mod m))).
+  1: rapply nat_mul_l_strictly_monotone.
+  rewrite <- nat_mul_assoc.
+  rewrite <- nat_dist_l.
+  apply ap.
+  symmetry; apply nat_div_mod_spec.
+Defined.
+
+(** We can cancel common factors on the right in a division. *)
+Definition nat_div_cancel_mul_r n m k
+  : 0 < k -> (n * k) / (m * k) = n / m.
+Proof.
+  rewrite 2 (nat_mul_comm _ k).
+  nrapply nat_div_cancel_mul_l.
+Defined.
+
+(** We can swap the order of division and multiplication on the left under certain conditions. *)
+Definition nat_div_mul_l n m k : (m | n) -> k * (n / m) = (k * n) / m.
+Proof.
+  intros H.
+  destruct (nat_zero_or_gt_zero m) as [[] | mp].
+  1: snrapply nat_mul_zero_r.
+  rapply (nat_div_unique _ _ _ 0 _ _)^.
+  lhs nrapply nat_add_zero_r.
+  lhs nrapply nat_mul_assoc.
+  lhs nrapply (ap (fun x => x * _)).
+  1: nrapply nat_mul_comm.
+  lhs_V nrapply nat_mul_assoc.
+  snrapply ap.
+  lhs_V nrapply nat_add_zero_r.
+  rhs nrapply (nat_div_mod_spec n m).
+  snrapply ap.
+  symmetry.
+  rapply nat_mod_divides.
+Defined.
+
+(** We can swap the order of division and multiplication on the right under certain conditions. *)
+Definition nat_div_mul_r n m k : (m | n) -> (n / m) * k = (n * k) / m.
+Proof.
+  rewrite 2 (nat_mul_comm _ k).
+  snrapply nat_div_mul_l.
+Defined.
+
+Definition nat_div_sub_mod n m : n / m = (n - n mod m) / m.
+Proof.
+  destruct (nat_zero_or_gt_zero m) as [[] | mp].
+  1: reflexivity.
+  symmetry.
+  rewrite nat_div_mod_spec''.
+  rapply nat_div_mul_cancel_l.
+Defined.
+
+(** Dividing a quotient is the same as dividing by the product of the divisors. *)
+Definition nat_div_div_l n m k : (n / m) / k = n / (m * k).
+Proof.
+  destruct (nat_zero_or_gt_zero k) as [[] | kp].
+  1: by rewrite nat_mul_zero_r.
+  destruct (nat_zero_or_gt_zero m) as [[] | mp].
+  1: snrapply nat_div_zero_l.
+  apply nat_div_unique with (r := (n mod (m * k)) / m).
+  { apply (lt_lt_leq_trans (m:=(m * k)/m)).
+    - rapply nat_div_strictly_monotone_r.
+      nrapply (nat_mod_lt_r' _ _ 0 _).
+      exact (nat_mul_strictly_monotone mp kp).
+    - by rewrite nat_div_mul_cancel_l. }
+  transitivity ((m * (k * (n / (m * k)))) / m + (n mod (m * k)) / m).
+  - f_ap.
+    symmetry; rapply nat_div_mul_cancel_l.
+  - rewrite nat_mul_assoc.
+    lhs_V nrapply nat_div_dist.
+    1: exact _.
+    apply (ap (fun x => x / m)).
+    symmetry; apply nat_div_mod_spec.
+Defined.
+
+(** Dividing a number by a quotient is the same as dividing the product of the number with the denominator of the quotient by the numerator of the quotient. *)
+Definition nat_div_div_r n m k : (k | m) -> n / (m / k) = (n * k) / m.
+Proof. 
+  intros [d r].
+  destruct (nat_zero_or_gt_zero k) as [[] | kp].
+  1: by rewrite nat_mul_zero_r, nat_div_zero_l.
+  destruct r.
+  rhs nrapply nat_div_cancel_mul_r.
+  2: exact _.
+  apply ap.
+  rapply nat_div_mul_cancel_r.
+Defined.
+
+(** A variant of [nat_div_div_r] without the divisibility assumption, by modifying [m] to become divisible. *)
+Definition nat_div_div_r' n m k : n / (m / k) = (n * k) / (m - m mod k).
+Proof.
+  rewrite (nat_div_sub_mod m k).
+  rapply nat_div_div_r.
+Defined.
+
+(** We can cancel common factors on the left in a modulo. *)
+Definition nat_mod_mul_l n m k
+  : (k * n) mod (k * m) = k * (n mod m).
+Proof.
+  destruct (nat_zero_or_gt_zero k) as [[] | kp].
+  1: reflexivity.
+  destruct (nat_zero_or_gt_zero m) as [[] | mp].
+  1: by rewrite nat_mul_zero_r.
+  apply (nat_mod_unique _ _ (n / m)).
+  1: rapply nat_mul_l_strictly_monotone.
+  rewrite <- nat_mul_assoc.
+  rewrite <- nat_dist_l.
+  apply ap.
+  symmetry; apply nat_div_mod_spec.
+Defined.
+
+(** We can cancel common factors on the right in a modulo. *)
+Definition nat_mod_mul_r n m k
+  : (n * k) mod (m * k) = (n mod m) * k.
+Proof.
+  rewrite 3 (nat_mul_comm _ k).
+  nrapply nat_mod_mul_l.
+Defined.
+
+(** ** Greatest Common Divisor *)
+
+(** The greatest common divisor of [0] and a number is the number itself. *)
+Definition nat_gcd_zero_l n : nat_gcd 0 n = n := idpath.
+
+(** The greatest common divisor of a number and [0] is the number itself. *)
+Definition nat_gcd_zero_r n : nat_gcd n 0 = n.
+Proof.
+  induction n; simpl; only 1: reflexivity.
+  by rewrite nat_sub_cancel.
+Defined.
+
+(** The greatest common divisor of [1] and any number is [1]. *)
+Definition nat_gcd_one_l n : nat_gcd 1 n = 1 := idpath.
+
+(** The greatest common divisor of any number and [1] is [1]. *)
+Definition nat_gcd_one_r n : nat_gcd n 1 = 1.
+Proof.
+  destruct n; trivial.
+  simpl.
+  destruct n; trivial.
+  rewrite nat_sub_succ_l; only 2: exact _.
+  by rewrite nat_sub_cancel.
+Defined.
+
+(** Idempotency. *)
+Definition nat_gcd_idem n : nat_gcd n n = n.
+Proof.
+  induction n.
+  1: reflexivity.
+  unfold nat_gcd; fold nat_gcd.
+  by rewrite nat_mod_cancel.
+Defined.
+
+(** We can prove that the greatest common divisor of [n] and [m] divides both [n] and [m]. This proof requires strong induction. *)
+Definition nat_divides_l_gcd n m : (nat_gcd n m | n) /\ (nat_gcd n m | m).
+Proof.
+  revert n m; snrapply nat_ind_strong; intros n IHn m.
+  destruct n.
+  1: split; exact _.
+  destruct (IHn (m mod n.+1) _ n.+1) as [H1 H2].
+  unfold nat_gcd; fold nat_gcd.
+  set (n' := n.+1) in *.
+  split; only 1: exact H2.
+  set (r := m mod n'); rewrite (nat_div_mod_spec m n'); unfold r; clear r.
+  exact _.
+Defined.
+
+(** The greatest common divisor of [n] and [m] divides [n]. *)
+Global Instance nat_divides_l_gcd_l n m : (nat_gcd n m | n)
+  := fst (nat_divides_l_gcd n m).
+
+(** The greatest common divisor of [n] and [m] divides [m]. *)
+Global Instance divides_l_nat_gcd_r n m : (nat_gcd n m | m)
+  := snd (nat_divides_l_gcd n m).
+
+(** We can prove that any common divisor of [n] and [m] divides the greatest common divisor of [n] and [m]. It is in that sense the greatest. *)
+Global Instance nat_divides_r_gcd n m p : (p | n) -> (p | m) -> (p | nat_gcd n m).
+Proof.
+  revert n m p; snrapply nat_ind_strong; intros n IHn m p H1 H2.
+  destruct n; only 1: exact _.
+  unfold nat_gcd; fold nat_gcd.
+  apply IHn; only 1,3: exact _.
+  rewrite (nat_div_mod_spec m n.+1) in H2.
+  apply nat_divides_add_r in H2; exact _.
+Defined.
+
+Definition nat_divides_r_iff_divides_r_gcd n m p
+  : (p | n) * (p | m) <-> (p | nat_gcd n m).
+Proof.
+  split; [intros [H1 H2] | intros H; split]; exact _.
+Defined.
+
+(** If [p] is divisible by all common divisors of [n] and [m], and [p] is also a common divisor, then it must necesserily be equal to the greatest common divisor. *)
+Definition nat_gcd_unique n m p
+  (H : forall q, (q | n) -> (q | m) -> (q | p))
+  : (p | n) -> (p | m) -> nat_gcd n m = p.
+Proof.
+  intros H1 H2.
+  rapply nat_divides_antisym.
+Defined.
+
+(** As a corollary of uniquness, we get that the greatest common divisor operation is commutative. *)
+Definition nat_gcd_comm n m : nat_gcd n m = nat_gcd m n.
+Proof.
+  rapply nat_gcd_unique.
+Defined.
+
+(** [nat_gcd] is associative. *)
+Definition nat_gcd_assoc n m k : nat_gcd n (nat_gcd m k) = nat_gcd (nat_gcd n m) k.
+Proof.
+  nrapply nat_gcd_unique.
+  - intros q H1 H2.
+    rapply nat_divides_r_gcd.
+  - rapply (nat_divides_trans (nat_divides_l_gcd_l _ _)).
+  - apply nat_divides_r_gcd; rapply nat_divides_trans.
+Defined.
+
+(** If [nat_gcd n m] is [0], then [n] must also be [0]. *)
+Definition nat_gcd_is_zero_l n m : nat_gcd n m = 0 -> n = 0.
+Proof.
+  intros H.
+  generalize (nat_divides_l_gcd_l n m).
+  rewrite H.
+  intros [x p].
+  exact (p^ @ nat_mul_zero_r _).
+Defined.
+
+(** If [nat_gcd n m] is [0], then [m] must also be [0]. *)
+Definition nat_gcd_is_zero_r n m : nat_gcd n m = 0 -> m = 0.
+Proof.
+  rewrite nat_gcd_comm.
+  apply nat_gcd_is_zero_l.
+Defined.
+
+(** [nat_gcd n m] is [0] if and only if both [n] and [m] are [0]. *)
+Definition nat_gcd_zero_iff_zero n m : nat_gcd n m = 0 <-> n = 0 /\ m = 0.
+Proof.
+  split.
+  - split.
+    + by apply (nat_gcd_is_zero_l _ m).
+    + by apply (nat_gcd_is_zero_r n).
+  - intros [-> ->].
+    reflexivity.
+Defined.
+
+(** [nat_gcd] is positive for positive inputs. *)
+Global Instance nat_gcd_pos n m : 0 < n -> 0 < m -> 0 < nat_gcd n m.
+Proof.
+  intros H1 H2.
+  apply lt_iff_not_geq.
+  intros H3; hnf in H3.
+  apply path_zero_leq_zero_r in H3.
+  apply nat_gcd_zero_iff_zero in H3.
+  destruct H3 as [->].
+  contradiction (not_lt_zero_r _ H1).
+Defined.
+
+Definition nat_gcd_l_add_r_mul n m k : nat_gcd (n + k * m) m = nat_gcd n m.
+Proof.
+  rapply nat_gcd_unique.
+  intros q H1 H2.
+  rapply nat_divides_r_gcd.
+  rapply (nat_divides_add_l _ _ (k * m)).
+Defined.
+
+Definition nat_gcd_r_add_r_mul n m k : nat_gcd n (m + k * n) = nat_gcd n m.
+Proof.
+  lhs nrapply nat_gcd_comm.
+  rhs nrapply nat_gcd_comm.
+  nrapply nat_gcd_l_add_r_mul.
+Defined.
+
+Definition nat_gcd_l_add_r n m : nat_gcd (n + m) m = nat_gcd n m.
+Proof.
+  rhs_V nrapply (nat_gcd_l_add_r_mul n m 1).
+  by rewrite nat_mul_one_l.
+Defined.
+
+Definition nat_gcd_r_add_r n m : nat_gcd n (m + n) = nat_gcd n m.
+Proof.
+  lhs nrapply nat_gcd_comm.
+  rhs nrapply nat_gcd_comm.
+  nrapply nat_gcd_l_add_r.
+Defined.
+
+Definition nat_gcd_l_sub n m : m <= n -> nat_gcd (n - m) m = nat_gcd n m.
+Proof.
+  intros H.
+  lhs_V nrapply nat_gcd_l_add_r.
+  by rewrite (nat_add_sub_l_cancel H).
+Defined.
+
+Definition nat_gcd_r_sub n m : n <= m -> nat_gcd n (m - n) = nat_gcd n m.
+Proof.
+  intros H.
+  lhs nrapply nat_gcd_comm.
+  rhs nrapply nat_gcd_comm.
+  rapply nat_gcd_l_sub.
+Defined.
+
+(** ** Bezout's Identity *)
+
+(** Bezout's identity states that for any two numbers [n] and [m], their greatest common divisor can be written as a linear combination of [n] and [m]. This is easy to state for the integers, however since we are working with the natural numbers, we need to be more careful. This is why we write the linear combination as [a * n = d + b * m] rather than the usual [a * n + b * m = d]. *)
+
+(** We define a predicate for triples of integers satisfying Bezout's identity. *)
+Definition NatBezout n m d : Type0
+  := exists a b, a * n = d + b * m.
+Existing Class NatBezout.
+
+Global Instance nat_bezout_refl_l n k : NatBezout n k n.
+Proof.
+  by exists 1, 0.
+Defined.
+
+(** If [a * n = 1 + b * m], then the gcd of [n] and [m] is [1]. *)
+Definition nat_bezout_coprime n m : NatBezout n m 1 -> nat_gcd n m = 1.
+Proof.
+  intros [a [b p]].
+  rapply nat_gcd_unique.
+  intros q H1 H2.
+  rapply (nat_divides_add_l _ _ (b * m)).
+  destruct p; exact _.
+Defined.
+
+Definition nat_bezout_comm n m d
+  : 0 < m -> NatBezout n m d -> NatBezout m n d.
+Proof.
+  intros H [a [b p]].
+  destruct (@equiv_leq_lt_or_eq 0 a _) as [|q].
+  - exists (n * a.+1 * b.+1 - b), (m * a.+1 * b.+1 - a).
+    rewrite 2 nat_dist_sub_r.
+    apply nat_moveR_nV.
+    rewrite <- nat_add_comm, nat_add_assoc, <- (nat_add_comm d).
+    rewrite <- nat_sub_l_add_r.
+    2: { apply nat_mul_r_monotone.
+      rewrite 2 nat_mul_succ_r.
+      nrapply (leq_trans _ (leq_add_l _ _)).
+      rapply (leq_trans _ (leq_add_r _ _)). }
+    apply nat_moveL_nV.
+    rewrite nat_add_comm.
+    snrapply (ap011 nat_add p).
+    lhs nrapply nat_mul_comm.
+    rhs_V nrapply nat_mul_assoc.
+    rhs_V nrapply nat_mul_assoc.
+    snrapply ap.
+    lhs_V nrapply nat_mul_assoc.
+    rhs nrapply nat_mul_assoc.
+    apply nat_mul_comm.
+  - destruct q.
+    exists 0, 0.
+    rewrite 2 nat_mul_zero_l, nat_add_zero_r in *.
+    symmetry in p; symmetry.
+    apply equiv_nat_add_zero in p.
+    by destruct p.
+Defined.
+Hint Immediate nat_bezout_comm : typeclass_instances.
+
+Global Instance nat_bezout_pos_l n m : 0 < n -> NatBezout n m (nat_gcd n m).
+Proof.
+  pose (k := n + m); assert (p : n + m = k) by reflexivity; clearbody k.
+  revert k n m p; snrapply nat_ind_strong; hnf; intros k IHk n m q H.
+  (** Given a sum [n + m], we can always find another pair [n' + m'] equal to that sum such that [n' < m']. This extra hypothesis lets us prove the statement more directly. *)
+  assert (H' : forall n' m', n + m = n' + m' -> 0 < n' -> n' < m'
+    -> NatBezout n' m' (nat_gcd n' m')).
+  { intros n' m' p H1 H2; destruct q.
+    assert (m' < n + m) by (rewrite p; change (0 + m' < n' + m'); exact _).
+    destruct (IHk m' _ n' (m' - n') (nat_add_sub_r_cancel _) _) as [a [b r]].
+    exists (a + b), b.
+    rewrite nat_dist_r, r, nat_dist_sub_l, <- nat_add_assoc.
+    rewrite nat_add_sub_l_cancel; only 2: rapply nat_mul_l_monotone.
+    snrapply (ap (fun x => x + _)).
+    rapply nat_gcd_r_sub. }
+  destruct (nat_trichotomy n m) as [[l | p] | r].
+  - by apply H'.
+  - destruct p.
+    rewrite nat_gcd_idem; exact _.
+  - destruct (@equiv_leq_lt_or_eq 0 m _).
+    + rewrite nat_gcd_comm.
+      rapply nat_bezout_comm.
+      rapply H'.
+      apply nat_add_comm.
+    + destruct p.
+      rewrite nat_gcd_zero_r; exact _.
+Defined.
+
+(** For strictly positive numbers, we have Bezout's identity in both directions. *)
+Definition nat_bezout_pos n m
+  : 0 < n -> 0 < m
+  -> NatBezout n m (nat_gcd n m) /\ NatBezout m n (nat_gcd n m).
+Proof.
+  intros H1 H2; split; [| apply nat_bezout_comm]; exact _.
+Defined.
+
+(** For arbitrary natural numbers, we have Bezout's identity in at least one direction. *)
+Definition nat_bezout n m
+  : NatBezout n m (nat_gcd n m) + NatBezout m n (nat_gcd n m).
+Proof.
+  destruct n; [ right | left ]; exact _.
+Defined.
+
+(** ** Prime Numbers *)
+
+(** A prime number is a number greater than [1] that is only divisible by [1] and itself. *)
+Class IsPrime (n : nat) : Type0 := {
+  gt_one_isprime :: 1 < n;
+  isprime : forall m, (m | n) -> (m = 1) + (m = n);
+}.
+
+Definition issig_IsPrime n : _ <~> IsPrime n := ltac:(issig).
+
+Global Instance ishprop_isprime `{Funext} n : IsHProp (IsPrime n).
+Proof.
+  nrapply istrunc_equiv_istrunc.
+  1: apply issig_IsPrime.
+  rapply istrunc_sigma.
+  intros H1.
+  snrapply istrunc_forall.
+  intros m.
+  snrapply istrunc_forall.
+  intros d.
+  rapply ishprop_sum.
+  intros p q.
+  nrapply (snd neq_iff_lt_or_gt _ (p^ @ q)).
+  by left.
+Defined.
+
+(** [0] is not a prime number. *)
+Definition not_isprime_zero : ~ IsPrime 0.
+Proof.
+  intros H.
+  rapply not_lt_zero_r.
+Defined.
+
+(** [1] is not a prime number. *)
+Definition not_isprime_one : ~ IsPrime 1.
+Proof.
+  intros H.
+  rapply (lt_irrefl 1).
+Defined.
+
+(** Being prime is a decidable property. We give an inefficient procedure for determining primality. More efficient procedures can be given, but for proofs this suffices. *)
+Global Instance decidable_isprime@{} n : Decidable (IsPrime n).
+Proof.
+  (** First we begin by discarding the [n = 0] case as we can easily prove that [0] is not prime. *)
+  destruct n.
+  1: right; apply not_isprime_zero.
+  (** Next, we rewrite [IsPrime n.+1] as the equivalent sigma type. *)
+  nrapply decidable_equiv'.
+  1: nrapply issig_IsPrime.
+  (** The condition in the first component in [IsPrime] is clearly decidable, so we can proceed to the second component. *)
+  nrapply decidable_equiv'.
+  1: exact (equiv_sigma_prod0 _ _)^-1%equiv.
+  snrapply decidable_prod.
+  1: exact _.
+  (** In order to show that this [forall] is decidable, we will exhibit it as a [for_all] statement over a given list. The predicate will be the conclusion we wish to reach here, and the list will consist of all numbers with a condition equivalent to the divisibility condition. *)
+  pose (P := fun m => ((m = 1) + (m = n.+1))%type : Type0).
+  pose (l := list_filter (seq n.+2) (fun x => (x | n.+1)) _).
+  rapply (decidable_iff (A := for_all P l)).
+  split.
+  - intros Pl x d.
+    apply inlist_for_all with l x in Pl.
+    1: exact Pl.
+    apply inlist_filter.
+    split; only 2: assumption.
+    apply inlist_seq.
+    apply leq_divides in d.
+    1,2: exact _.
+  - intros H.
+    apply for_all_inlist.
+    intros x H'.
+    apply inlist_filter in H'.
+    destruct H' as [p H'].
+    apply inlist_seq in p.
+    rapply H.
+Defined.
+
+(** We can show that the first 8 primes are prime as expected. *)
+Global Instance isprime_2 : IsPrime 2 := ltac:(decide).
+Global Instance isprime_3 : IsPrime 3 := ltac:(decide).
+Global Instance isprime_5 : IsPrime 5 := ltac:(decide).
+Global Instance isprime_7 : IsPrime 7 := ltac:(decide).
+Global Instance isprime_11 : IsPrime 11 := ltac:(decide).
+Global Instance isprime_13 : IsPrime 13 := ltac:(decide).
+Global Instance isprime_17 : IsPrime 17 := ltac:(decide).
+Global Instance isprime_19 : IsPrime 19 := ltac:(decide).
+
+(** Similarly, we can see that other natural numbers are not prime. *)
+Definition not_isprime_0 : not (IsPrime 0) := ltac:(decide).
+Definition not_isprime_1 : not (IsPrime 1) := ltac:(decide).
+Definition not_isprime_4 : not (IsPrime 4) := ltac:(decide).
+
+(** We can define the type of prime numbers as a subtype of natural numbers. *)
+Definition Prime : Type0 := {n : nat & IsPrime n}.
+
+Coercion nat_of_prime (p : Prime) : nat := p.1.
+Global Instance isprime_prime (p : Prime) : IsPrime p := p.2.
+
+Global Instance lt_zero_prime (p : Prime) : 0 < p
+  := lt_trans _ gt_one_isprime.
+
+(** A prime [p] is coprime to a natural number [n] iff [p] does not divide [n]. *)
+Definition nat_coprime_iff_not_divides (p : Prime) n
+  : nat_gcd p n = 1 <-> ~ (p | n).
+Proof.
+  split.
+  - intros q [d r].
+    destruct r.
+    rewrite (nat_gcd_r_add_r_mul p 0) in q.
+    rewrite nat_gcd_zero_r in q.
+    apply (@neq_iff_lt_or_gt p 1).
+    1: right; exact _.
+    exact q.
+  - intros nd.
+    rapply nat_gcd_unique.
+    intros q H1 H2.
+    apply isprime in H1.
+    destruct H1 as [H1|H1].
+    + destruct H1; exact _.
+    + destruct H1; contradiction.
+Defined.
+
+(** When a prime number divides a multiple, then the prime must divide one of the factors. *)
+Definition nat_divides_prime_l (p : Prime) n m
+  : (p | n * m) -> (p | n) + (p | m).
+Proof.
+  intros d.
+  destruct (dec (p | n)) as [H|H].
+  1: by left.
+  right.
+  apply nat_coprime_iff_not_divides in H.
+  destruct (nat_bezout_pos_l p n _) as [x [y q]].
+  destruct H^; clear H.
+  destruct d as [d r].
+  exists (x * m - y * d).
+  lhs nrapply nat_dist_sub_r.
+  rewrite <- 2 nat_mul_assoc.
+  rewrite <- (nat_mul_comm p).
+  destruct r^; clear r.
+  rewrite 2 nat_mul_assoc.
+  lhs_V nrapply nat_dist_sub_r.
+  rhs_V nrapply nat_mul_one_l.
+  apply (ap (fun x => nat_mul x m)).
+  apply nat_moveR_nV.
+  exact q.
+Defined.
+
+(** ** Composite Numbers *)
+
+(** A natural number larger than [1] is composite if it has a divisor other than [1] and itself. *)
+Class IsComposite n : Type0
+  := iscomposite : exists a, 1 < a < n /\ (a | n).
+
+Definition gt_1_iscomposite@{} n : IsComposite n -> 1 < n.
+Proof.
+  intros [a [[H1 H2] H3]].
+  exact _.
+Defined.
+Hint Immediate gt_1_iscomposite : typeclass_instances.
+
+(** Being composite is a decidable property. *)
+Global Instance decidable_iscomposite@{} n : Decidable (IsComposite n).
+Proof.
+  unfold IsComposite.
+  rapply (decidable_exists_nat n).
+  intros k c.
+  exact (snd (fst c)).
+Defined.
+
+(** For a number larger than [1], being prime is equivalent to not being composite. *)
+Definition isprime_iff_not_iscomposite@{} n
+  : IsPrime n <-> 1 < n /\ ~ IsComposite n.
+Proof.
+  split.
+  - intros H.
+    split; only 1: exact _.
+    intros [a [[H2 H3] H4]].
+    apply isprime in H4.
+    destruct H4 as [H4|H4]; destruct H4; exact (lt_irrefl _ _).
+  - intros [H1 H].
+    rapply Build_IsPrime.
+    intros m d.
+    destruct (dec (1 < d.1)) as [H2|H2].
+    + pose proof (divides_divisor _ _ d) as d'.
+      apply leq_divides in d'.
+      2: exact _.
+      apply equiv_leq_lt_or_eq in d'.
+      destruct d' as [d'|d'].
+      * assert (H' : IsComposite n).
+        { exists d.1.
+          split; only 1: split; exact _. }
+          contradiction H.
+      * destruct d as [d r].
+        simpl in *.
+        destruct d'.
+         left.
+         rewrite <- nat_div_cancel with d.
+         2: exact _.
+         rewrite <- nat_div_mul_cancel_l with d m.
+         2: exact _.
+         by apply (ap (fun x => x / d)).
+    + apply geq_iff_not_lt in H2.
+      destruct d as [d r].
+      simpl in *; hnf in H2.
+      destruct d.
+      { rewrite nat_mul_zero_l in r.
+        destruct n.
+        1: contradiction (not_lt_zero_r _ H1).
+        contradiction (neq_nat_zero_succ _ r). }
+      destruct d.
+      { rewrite nat_mul_one_l in r.
+        by right. }
+      apply leq_pred' in H2.
+      contradiction (not_lt_zero_r d).
+Defined.
+
+(** And since [IsComposite] is decidable, we can show that being not prime is equivalent to being composite. *)
+Definition not_isprime_iff_iscomposite@{} n
+  : 1 < n /\ ~ IsPrime n <-> IsComposite n.
+Proof.
+  nrapply iff_compose.
+  - nrapply iff_functor_prod.
+    1: nrapply iff_refl.
+    nrapply iff_compose.
+    + apply iff_not.
+      rapply isprime_iff_not_iscomposite.
+    + rapply iff_not_prod.
+  - nrapply iff_compose.
+    1: nrapply sum_distrib_l.
+    nrapply iff_compose.
+    + nrapply iff_functor_sum.
+      1: apply iff_contradiction.
+      nrapply iff_functor_prod.
+      1: nrapply iff_refl.
+      rapply iff_stable.
+    + nrapply iff_compose.
+      1: rapply sum_empty_l.
+      split; only 1: exact snd.
+      intros H; split; only 2: exact H.
+      exact _.
+Defined.
+
+(** ** Fundamental theorem of arithmetic *)
+
+(** Every natural number greater than [1] has a prime divisor. *)
+Definition exists_prime_divisor@{} n
+  : 1 < n -> exists (p : Prime), (p | n).
+Proof.
+  revert n; snrapply nat_ind_strong; hnf; intros n IHn H.
+  destruct (dec (IsPrime n)) as [x|x].
+  1: exists (_; x); exact _.
+  pose (r := (H, x)).
+  apply not_isprime_iff_iscomposite in r.
+  destruct r as [d [[H1 H2] H3]].
+  destruct (IHn d _ _) as [p r].
+  exists p.
+  exact _.
+Defined.
+
+(** Any natural number can either be written as a product of primes or is zero. *)
+Definition prime_factorization@{} n
+  : 0 < n
+    -> exists (l : list Prime),
+      n = fold_right (fun (p : Prime) n => nat_mul p n) 1 l.
+Proof.
+  revert n; snrapply nat_ind_strong; hnf; intros n IHn H.
+  destruct H as [|n IH].
+  1: exists nil; reflexivity.
+  destruct (exists_prime_divisor n.+1 _) as [p d].
+  pose proof (l := lt_divides d.1 n.+1 _ _ _).
+  destruct d as [k H].
+  destruct (IHn k l) as [f r].
+  { destruct H, k.
+    1: contradiction (lt_irrefl 0).
+    exact _. }
+  exists (p :: f)%list.
+  simpl; destruct r.
+  symmetry.
+  lhs nrapply nat_mul_comm.
+  exact H.
+Defined.
+
+(** TODO: show that any two prime factorizations are unique up to permutation of the lists. *)
diff --git a/theories/Spaces/Nat/Factorial.v b/theories/Spaces/Nat/Factorial.v
new file mode 100644
index 00000000000..8952186aa7e
--- /dev/null
+++ b/theories/Spaces/Nat/Factorial.v
@@ -0,0 +1,112 @@
+Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids
+  Basics.Decidable Spaces.Nat.Core Spaces.Nat.Division Tactics.EvalIn.
+
+Local Set Universe Minimization ToSet.
+
+Local Open Scope nat_scope.
+
+(** * Factorials *)
+
+(** ** Definition *)
+
+Fixpoint factorial n := 
+  match n with
+  | 0 => 1
+  | S n => S n * factorial n
+  end.
+
+(** ** Properties *)
+
+(** The factorial of [0] is [1]. *)
+Definition nat_factorial_zero : factorial 0 = 1 := idpath.
+
+(** The factorial of [n + 1] is [n + 1] times the factorial of [n]. *)
+Definition nat_factorial_succ n : factorial n.+1 = n.+1 * factorial n
+  := idpath.
+
+(** A variant of [nat_factorial_succ]. *)
+Definition nat_factorial_pred n
+  : 0 < n -> factorial n = n * factorial (nat_pred n).
+Proof.
+  intros []; reflexivity.
+Defined.
+
+(** Every factorial is positive. *)
+Global Instance lt_zero_factorial n : 0 < factorial n.
+Proof.
+  induction n; exact _.
+Defined.
+
+(** Except for [factorial 0 = factorial 1], the [factorial] function is strictly monotone.  We separate out the successor case since it is used twice in the proof of the general result. *)
+Definition nat_factorial_strictly_monotone_succ n
+  : 0 < n -> factorial n < factorial n.+1.
+Proof.
+  intro H.
+  rewrite <- (nat_mul_one_l (factorial n)).
+  rapply (nat_mul_r_strictly_monotone _).
+Defined.
+
+Global Instance nat_factorial_strictly_monotone n m
+  : 0 < n -> n < m -> factorial n < factorial m.
+Proof.
+  intros H1 H2; induction H2.
+  - rapply nat_factorial_strictly_monotone_succ.
+  - apply (lt_trans IHleq).
+    rapply nat_factorial_strictly_monotone_succ.
+Defined.
+
+(** ** Divisibility *)
+
+(** Any number less than or equal to [n] divides [factorial n]. *)
+Global Instance nat_divides_factorial_factor n m
+  : 0 < n -> n <= m -> (n | factorial m).
+Proof.
+  intros [] H2.
+  1: exact _.
+  induction H2; exact _.
+Defined.
+
+(** [factorial] is a monotone function from [nat] to [nat] with respect to [<=] and divides. *)
+Global Instance nat_divides_factorial_lt n m
+  : n <= m -> (factorial n | factorial m).
+Proof.
+  intros H; induction H; exact _.
+Defined.
+
+(** A product of factorials divides the factorial of the sum. *)
+Global Instance nat_divides_factorial_mul_factorial_add n m
+  : (factorial n * factorial m | factorial (n + m)).
+Proof.
+  remember (n + m) as k eqn:p.
+  revert k n m p; snrapply nat_ind_strong; hnf; intros k IH n m p.
+  destruct k.
+  { apply equiv_nat_add_zero in p.
+    destruct p as [p q].
+    destruct p^, q^.
+    exact _. }
+  rewrite_refl nat_factorial_succ.
+  rewrite <- p.
+  rewrite nat_dist_r.
+  assert (helper : forall n' m' (p' : n' + m' = k.+1), (factorial n' * factorial m' | n' * factorial k)).
+  - intros n' m' p'.
+    destruct n'; only 1: exact _.
+    rewrite nat_factorial_succ.
+    rewrite <- nat_mul_assoc.
+    rapply nat_divides_mul_monotone.
+    rapply IH.
+    exact (ap nat_pred p').
+  - nrapply nat_divides_add.
+    + apply helper, p.
+    + rewrite nat_mul_comm.
+      apply helper.
+      lhs nrapply nat_add_comm; exact p.
+Defined.
+
+(** Here is a variant of [nat_divides_factorial_mul_factorial_add] that is more suitable for binomial coefficients. *)
+Global Instance nat_divides_factorial_mul_factorial_add' n m
+  : m <= n -> (factorial m * factorial (n - m) | factorial n).
+Proof.
+  intros H.
+  rewrite <- (ap factorial (nat_add_sub_r_cancel H)).
+  apply nat_divides_factorial_mul_factorial_add.
+Defined.
diff --git a/theories/Spaces/Nat/Paths.v b/theories/Spaces/Nat/Paths.v
new file mode 100644
index 00000000000..c8e3e49b993
--- /dev/null
+++ b/theories/Spaces/Nat/Paths.v
@@ -0,0 +1,49 @@
+Require Import Basics.
+Require Export Basics.Nat.
+Require Export HoTT.DProp.
+
+(** * Characterization of the path types of [nat] *)
+
+(** We characterize the path types of [nat].  We put this in its own file because it uses DProp, which has a lot of dependencies. *)
+
+Local Set Universe Minimization ToSet.
+
+Local Close Scope trunc_scope.
+Local Open Scope nat_scope.
+
+Fixpoint code_nat (m n : nat) {struct m} : DHProp@{Set} :=
+  match m, n with
+  | 0, 0 => True
+  | m'.+1, n'.+1 => code_nat m' n'
+  | _, _ => False
+  end.
+
+Infix "=n" := code_nat : nat_scope.
+
+Fixpoint idcode_nat {n} : (n =n n) :=
+  match n as n return (n =n n) with
+  | 0 => tt
+  | S n' => @idcode_nat n'
+  end.
+
+Fixpoint path_nat {n m} : (n =n m) -> (n = m) :=
+  match m as m, n as n return (n =n m) -> (n = m) with
+  | 0, 0 => fun _ => idpath
+  | m'.+1, n'.+1 => fun H : (n' =n m') => ap S (path_nat H)
+  | _, _ => fun H => match H with end
+  end.
+
+Global Instance isequiv_path_nat {n m} : IsEquiv (@path_nat n m).
+Proof.
+  refine (isequiv_adjointify
+            (@path_nat n m)
+            (fun H => transport (fun m' => (n =n m')) H idcode_nat)
+            _ _).
+  { intros []; simpl.
+    induction n; simpl; trivial.
+    by destruct (IHn^)%path. }
+  { intro. apply path_ishprop. }
+Defined.
+
+Definition equiv_path_nat {n m} : (n =n m) <~> (n = m)
+  := Build_Equiv _ _ (@path_nat n m) _.
diff --git a/theories/Spaces/No/Addition.v b/theories/Spaces/No/Addition.v
index a20fe702477..94187db35a8 100644
--- a/theories/Spaces/No/Addition.v
+++ b/theories/Spaces/No/Addition.v
@@ -298,7 +298,7 @@ Section Addition.
     refine (path_No_easy _ _ _ _ eL eR _ _ _ _);
     intros;
     repeat match goal with
-           | [ H : (?A + ?B)%type |- _ ] => destruct H
+           | [ H : (?A + ?B) |- _ ] => destruct H
            end;
     repeat match goal with
            | [ |- context[@equiv_fun ?A ?B ?e ?v] ]
diff --git a/theories/Spaces/No/Core.v b/theories/Spaces/No/Core.v
index f78ccdac3ae..17cc723f81a 100644
--- a/theories/Spaces/No/Core.v
+++ b/theories/Spaces/No/Core.v
@@ -1067,7 +1067,7 @@ Section RaiseSort.
       strip_truncations.
       destruct sh as [[l sh]|[r sh]].
       + apply lt_l with l.
-        apply IHL0, (@No_decode_le ua). (* Need to pass in [Univalence] to make this fast. TODO: should be fast without ua with Coq 8.19.  If so, remove this when 8.19 is our minimum version. *)
+        apply IHL0, No_decode_le.
         rewrite p; exact sh.
       + apply lt_r with r.
         apply IHR, No_decode_le.
diff --git a/theories/Spaces/Pos/Core.v b/theories/Spaces/Pos/Core.v
index a76ffe22853..618ff236d45 100644
--- a/theories/Spaces/Pos/Core.v
+++ b/theories/Spaces/Pos/Core.v
@@ -268,18 +268,25 @@ Infix "*" := pos_mul : positive_scope.
 Definition pos_iter {A : Type} (f : A -> A)
   : Pos -> A -> A.
 Proof.
-  apply (pos_peano_ind (fun _ => A -> A) f).
+  apply (pos_peano_rec (A -> A) f).
   intros n g.
   exact (f o g).
 Defined.
 
+(** ** Iteration of a two-variable function, with nesting reflecting the bits *)
+
+Definition pos_iter_op {A} (op : A -> A -> A)
+  := fix p_iter (p : Pos) (a : A) : A
+    := match p with
+        | 1 => a
+        | p~0 => p_iter p (op a a)
+        | p~1 => op a (p_iter p (op a a))
+       end.
+
 (** ** Power *)
 
 Definition pos_pow (x : Pos) := pos_iter (pos_mul x) 1.
 
-(* We cannot use this notation because it is reserved for path inverse. *)
-(* Infix "^" := pos_pow : positive_scope. *)
-
 (** ** Square *)
 
 Fixpoint pos_square p :=
@@ -327,13 +334,9 @@ Fixpoint pos_size p :=
 
 (** ** From binary positive numbers to Peano natural numbers *)
 
-Definition pos_iter_op {A} (op : A -> A -> A)
-  := fix pos_iter (p : Pos) (a : A) : A
-    := match p with
-        | 1 => a
-        | p~0 => pos_iter p (op a a)
-        | p~1 => op a (pos_iter p (op a a))
-       end.
+(** Sends [n] to [n], missing [0]. *)
+Definition nat_of_pos (p : Pos) : nat
+  := pos_iter S p 0%nat.
 
 (** ** From Peano natural numbers to binary positive numbers *)
 
@@ -417,8 +420,8 @@ Definition pos_to_nat : Pos -> nat.
 Proof.
   intro p. induction p.
   + exact (S O).
-  + exact (add IHp IHp).
-  + exact (S (add IHp IHp)).
+  + exact (nat_add IHp IHp).
+  + exact (S (nat_add IHp IHp)).
 Defined.
 
 Number Notation Pos pos_of_number_uint pos_to_number_uint : positive_scope.
diff --git a/theories/Spaces/Pos/Spec.v b/theories/Spaces/Pos/Spec.v
index 0df011990d4..29437979d6c 100644
--- a/theories/Spaces/Pos/Spec.v
+++ b/theories/Spaces/Pos/Spec.v
@@ -189,7 +189,7 @@ Lemma pos_iter_succ_l {A} (f : A -> A) p a
   : pos_iter f (pos_succ p) a = f (pos_iter f p a).
 Proof.
   unfold pos_iter.
-  by rewrite pos_peano_ind_beta_pos_succ.
+  by rewrite pos_peano_rec_beta_pos_succ.
 Qed.
 
 Lemma pos_iter_succ_r {A} (f : A -> A) p a
@@ -201,7 +201,7 @@ Proof.
   hnf; intros p q f a.
   refine (_ @ _ @ _^).
   1,3: unfold pos_iter;
-    by rewrite pos_peano_ind_beta_pos_succ.
+    by rewrite pos_peano_rec_beta_pos_succ.
   apply ap.
   apply q.
 Qed.
diff --git a/theories/Spaces/Torus/Torus.v b/theories/Spaces/Torus/Torus.v
index abc7d650706..4bbc2a5e9fb 100644
--- a/theories/Spaces/Torus/Torus.v
+++ b/theories/Spaces/Torus/Torus.v
@@ -25,12 +25,12 @@ Module Export Torus.
   Axiom Torus_ind_beta_loop_a : forall (P : Torus -> Type) (pb : P tbase)
     (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb)
     (ps : DPathSquare P surf pla pla plb plb), DPathSquare P hr
-      (dp_apD (Torus_ind P pb pla plb ps) (loop_a)) pla 1%dpath 1%dpath.
+      (apD (Torus_ind P pb pla plb ps) (loop_a)) pla 1%dpath 1%dpath.
 
   Axiom Torus_ind_beta_loop_b : forall (P : Torus -> Type) (pb : P tbase)
     (pla : DPath P loop_a pb pb) (plb : DPath P loop_b pb pb)
     (ps : DPathSquare P surf pla pla plb plb), DPathSquare P hr
-      (dp_apD (Torus_ind P pb pla plb ps) (loop_b)) plb 1%dpath 1%dpath.
+      (apD (Torus_ind P pb pla plb ps) (loop_b)) plb 1%dpath 1%dpath.
 
   (** We write out the computation rule for surf even though we will not use it. Instead we currently have an unfinished recursion computation principle, but we don't currently know how to derive it from this *)
   Axiom Torus_ind_beta_surf : forall (P : Torus -> Type) (pb : P tbase)
diff --git a/theories/Spaces/Torus/TorusEquivCircles.v b/theories/Spaces/Torus/TorusEquivCircles.v
index c4a496d38a8..eed92e15b92 100644
--- a/theories/Spaces/Torus/TorusEquivCircles.v
+++ b/theories/Spaces/Torus/TorusEquivCircles.v
@@ -35,7 +35,7 @@ Proof.
     - exact tbase.      (* The basepoint is sent to the point of the torus *)
     - exact loop_b.     (* The second loop is sent to loop_b *)
   + apply path_forall.  (* We use function extensionality here to induct *)
-    snrapply Circle_ind_dp.  (* Circle induction as a DPath *)
+    snrapply Circle_ind.  (* Circle induction as a DPath *)
     - exact loop_a.     (* The first loop is sent to loop_a *)
     - srapply sq_dp^-1. (* This DPath is actually a square *)
       apply (pr1 c2t_square_and_cube). (* We apply the cap we found above *)
@@ -66,8 +66,8 @@ Proof.
   (* 3. Reducing ap10 on function extensionality *)
   nrefine (cu_concat_lr (cu_ds (dp_apD_nat (ap10_path_forall _ _ _) _)) _
     (sji0:=?[X3]) (sji1:=?X3) (sj0i:=?[Y3]) (sj1i:=?Y3) (pj11:=1)).
-  (* 4. Reducing Circle_ind_dp on loop *)
-  nrefine (cu_concat_lr (cu_G11 (ap _ (Circle_ind_dp_beta_loop _ _ _))) _
+  (* 4. Reducing Circle_ind on loop *)
+  nrefine (cu_concat_lr (cu_G11 (ap _ (Circle_ind_beta_loop _ _ _))) _
     (sji0:=?[X4]) (sji1:=?X4) (sj0i:=?[Y4]) (sj1i:=?Y4) (pj11:=1)).
   (* 5. collapsing equivalence *)
   nrefine (cu_concat_lr (cu_G11 (eisretr _ _)) _
@@ -144,17 +144,17 @@ Definition c2t2c `{Funext} : t2c o c2t == idmap.
 Proof.
   nrapply prod_ind.
   (* Start with double circle induction *)
-  snrefine (Circle_ind_dp _ (Circle_ind_dp _ 1 _) _).
+  snrefine (Circle_ind _ (Circle_ind _ 1 _) _).
   (* Change the second loop case into a square and shelve *)
   1: apply sq_dp^-1, sq_tr^-1; shelve.
   (* Take the forall out of the DPath *)
   apply dp_forall_domain.
   intro x; apply sq_dp^-1; revert x.
-  snrefine (Circle_ind_dp _ _ _).
+  snrefine (Circle_ind _ _ _).
   1: apply sq_tr^-1; shelve.
   apply dp_cu.
   nrefine (cu_ccGGcc _ _ _).
-  1,2: nrefine (ap sq_dp (Circle_ind_dp_beta_loop _ _ _)
+  1,2: nrefine (ap sq_dp (Circle_ind_beta_loop _ _ _)
     @ eisretr _ _)^.
   apply cu_rot_tb_fb.
   nrefine (cu_ccGGGG _ _ _ _ _).
diff --git a/theories/Spaces/Torus/TorusHomotopy.v b/theories/Spaces/Torus/TorusHomotopy.v
index 839212d9981..ef20a811351 100644
--- a/theories/Spaces/Torus/TorusHomotopy.v
+++ b/theories/Spaces/Torus/TorusHomotopy.v
@@ -4,7 +4,7 @@ Require Import Modalities.ReflectiveSubuniverse Truncations.Core.
 Require Import Algebra.AbGroups.
 Require Import Homotopy.HomotopyGroup.
 Require Import Homotopy.PinSn.
-Require Import Spaces.Int.Core Spaces.Circle.
+Require Import Spaces.Int Spaces.Circle.
 
 Require Import Spaces.Torus.Torus.
 Require Import Spaces.Torus.TorusEquivCircles.
diff --git a/theories/Tactics.v b/theories/Tactics.v
index a0714555fe5..0518bd4438c 100644
--- a/theories/Tactics.v
+++ b/theories/Tactics.v
@@ -49,7 +49,7 @@ Lemma path_forall_recr_beta' `{Funext} A B x0 P f g e Px
              g
              (@path_forall _ _ _ _ _ e)
              Px
-  = @transport ((forall a, B a) * B x0)%type
+  = @transport ((forall a, B a) * B x0)
                (fun x => P (fst x) (snd x))
                (f, f x0)
                (g, g x0)
@@ -140,7 +140,7 @@ Ltac transport_path_forall_hammer :=
 (** An example showing that it works *)
 Lemma path_forall_2_beta' `{Funext} A B x0 x1 P f g e Px
 : @transport (forall a : A, B a) (fun f => P (f x0) (f x1)) f g (@path_forall _ _ _ _ _ e) Px
-  = @transport (B x0 * B x1)%type (fun x => P (fst x) (snd x)) (f x0, f x1) (g x0, g x1) (path_prod' (e x0) (e x1)) Px.
+  = @transport (B x0 * B x1) (fun x => P (fst x) (snd x)) (f x0, f x1) (g x0, g x1) (path_prod' (e x0) (e x1)) Px.
 Proof.
   transport_path_forall_hammer.
   repeat match goal with
diff --git a/theories/Tactics/Nameless.v b/theories/Tactics/Nameless.v
index 390423165d7..3328416014c 100644
--- a/theories/Tactics/Nameless.v
+++ b/theories/Tactics/Nameless.v
@@ -14,13 +14,13 @@ Tactic Notation "syntax_enforce" "[" constr(H) ":=" open_constr(body) "]" := let
 Tactic Notation "enforce" "[" open_constr(x) "=" open_constr(y) "]" := unify x y.
 
 (** An example *)
-Goal False -> let X0 := I in False -> True.
+Goal Empty -> let X0 := tt in Empty -> Unit.
 Proof.
   intros.
   let H := hyp in
-  enforce (H : Logic.True);
-    syntax_enforce [ H := I ];
+  enforce (H : Unit);
+    syntax_enforce [ H := tt ];
     enforce [ H = _ ];
     enforce [ _ = H ];
-    enforce [ H = I ].
+    enforce [ H = tt ].
 Abort.
diff --git a/theories/Types/Arrow.v b/theories/Types/Arrow.v
index f196622b453..9b56ad49b7b 100644
--- a/theories/Types/Arrow.v
+++ b/theories/Types/Arrow.v
@@ -2,10 +2,11 @@
 (** * Theorems about Non-dependent function types *)
 
 Require Import Basics.Overture Basics.PathGroupoids Basics.Decidable
-               Basics.Equivalences Basics.Trunc Basics.Tactics.
+               Basics.Equivalences Basics.Trunc Basics.Tactics Basics.Iff.
 Require Import Types.Forall.
 Local Open Scope path_scope.
 
+Local Set Universe Minimization ToSet.
 
 Generalizable Variables A B C D f g n.
 
@@ -208,6 +209,13 @@ Definition not_contrapositive `(f : B -> A)
   : not A -> not B
   := functor_arrow f idmap.
 
+Definition iff_not@{u v k | u <= k, v <= k}
+  (A : Type@{u}) (B : Type@{v})
+  : A <-> B -> iff@{u v k} (~A) (~B).
+Proof.
+  intros e; split; apply not_contrapositive@{_ k}, e.
+Defined.
+
 Definition ap_functor_arrow `(f : B -> A) `(g : C -> D)
   (h h' : A -> C) (p : h == h')
   : ap (functor_arrow f g) (path_arrow _ _ p)
diff --git a/theories/Types/Bool.v b/theories/Types/Bool.v
index 830a5b0987e..61419d0fb9b 100644
--- a/theories/Types/Bool.v
+++ b/theories/Types/Bool.v
@@ -92,6 +92,16 @@ Proof.
   - intros oops; case (oops idpath).
 Defined.
 
+(** This version of [negb_ne] is more convenient to [destruct] against. *)
+Definition negb_ne' {b1 b2 : Bool}
+  : (b1 <> b2) -> (negb b1 = b2).
+Proof.
+  intros oops.
+  symmetry.
+  apply negb_ne.
+  exact (symmetric_neq oops).
+Defined.
+
 (** ** Products as [forall] over [Bool] *)
 
 Section BoolForall.
diff --git a/theories/Types/Forall.v b/theories/Types/Forall.v
index 22f65cc5094..8b30a5247ac 100644
--- a/theories/Types/Forall.v
+++ b/theories/Types/Forall.v
@@ -2,7 +2,7 @@
 (** * Theorems about dependent products *)
 
 Require Import Basics.Overture Basics.Equivalences Basics.PathGroupoids
-               Basics.Tactics Basics.Trunc Basics.Contractible.
+               Basics.Tactics Basics.Contractible Basics.Iff.
 
 Require Export Basics.Trunc (istrunc_forall).
 
@@ -50,7 +50,7 @@ Definition equiv_path_forall `{P : A -> Type} (f g : forall x, P x)
   : (f == g)  <~>  (f = g)
   := Build_Equiv _ _ (path_forall f g) _.
 
-Global Arguments equiv_path_forall {A%type_scope P} (f g)%function_scope.
+Global Arguments equiv_path_forall {A%_type_scope P} (f g)%_function_scope.
 
 (** ** Path algebra *)
 
@@ -314,12 +314,9 @@ Defined.
 (** At least over a fixed base *)
 Definition iff_functor_forall {A : Type} {P Q : A -> Type}
            (f : forall a, P a <-> Q a)
-  : (forall a, P a) <-> (forall a, Q a).
-Proof.
-  split.
-  - intros g a; exact (fst (f a) (g a)).
-  - intros h a; exact (snd (f a) (h a)).
-Defined.
+  : (forall a, P a) <-> (forall a, Q a)
+  := (functor_forall idmap (fun a => fst (f a)),
+    functor_forall idmap (fun a => snd (f a))).
 
 (** ** Two variable versions for function extensionality. *)
 
@@ -335,9 +332,9 @@ Global Instance isequiv_path_forall11 {A : Type} {B : A -> Type} `{P : forall a
   : IsEquiv (path_forall11 f g) | 0
   := _.
 
-Global Arguments equiv_path_forall11 {A B}%type_scope {P} (f g)%function_scope.
+Global Arguments equiv_path_forall11 {A B}%_type_scope {P} (f g)%_function_scope.
 
-Global Arguments path_forall11 {A B}%type_scope {P} (f g)%function_scope _.
+Global Arguments path_forall11 {A B}%_type_scope {P} (f g)%_function_scope _.
 
 (** ** Truncatedness: any dependent product of n-types is an n-type: see [contr_forall] and [istrunc_forall] in Basics.Trunc. *)
 
@@ -366,6 +363,8 @@ Definition flip `{P : A -> B -> Type}
   : (forall a b, P a b) -> (forall b a, P a b)
   := fun f b a => f a b.
 
+Arguments flip {A B P} f b a /.
+
 Global Instance isequiv_flip `{P : A -> B -> Type}
   : IsEquiv (@flip _ _ P) | 0.
 Proof.
diff --git a/theories/Types/Option.v b/theories/Types/Option.v
new file mode 100644
index 00000000000..428bcec3e8e
--- /dev/null
+++ b/theories/Types/Option.v
@@ -0,0 +1,20 @@
+Require Import Basics.Overture.
+
+(** * Option types *)
+
+(** Option types are a simple way to represent a value that may or may not be present. They are also known as the Maybe monad in functional programming. *)
+
+(** [option] is functorial. *)
+Definition functor_option {A B} (f : A -> B) (x : option A) : option B :=
+  match x with
+  | None => None
+  | Some a => Some (f a)
+  end.
+
+(** The [Some] constructor is injective. *)
+Definition isinj_some {A} {x y : A} (p : Some x = Some y)
+  : x = y.
+Proof.
+  injection p.
+  exact idmap.
+Defined.
diff --git a/theories/Types/Prod.v b/theories/Types/Prod.v
index 4ff20b28431..cb406ea19c1 100644
--- a/theories/Types/Prod.v
+++ b/theories/Types/Prod.v
@@ -2,10 +2,12 @@
 (** * Theorems about cartesian products *)
 
 Require Import Basics.Overture Basics.Equivalences Basics.PathGroupoids
-               Basics.Tactics Basics.Trunc Basics.Decidable.
+               Basics.Tactics Basics.Trunc Basics.Decidable Basics.Iff.
 Require Import Types.Empty.
 Local Open Scope path_scope.
 
+Local Set Universe Minimization ToSet.
+
 Generalizable Variables X A B f g n.
 
 Scheme prod_ind := Induction for prod Sort Type.
@@ -300,11 +302,11 @@ Defined.
 
 (** ** Unit and annihilation *)
 
-Definition prod_empty_r X : X * Empty <~> Empty
-  := (Build_Equiv _ _ snd _).
+Definition prod_empty_r@{u} (X : Type@{u}) : X * Empty <~> Empty
+  := (Build_Equiv@{u u} _ _ snd _).
 
-Definition prod_empty_l X : Empty * X <~> Empty
-  := (Build_Equiv _ _ fst _).
+Definition prod_empty_l@{u} (X : Type@{u}) : Empty * X <~> Empty
+  := (Build_Equiv@{u u} _ _ fst _).
 
 Definition prod_unit_r X : X * Unit <~> X.
 Proof.
@@ -391,13 +393,13 @@ Global Instance contr_prod `{CA : Contr A} `{CB : Contr B} : Contr (A * B) | 100
 
 Global Instance decidable_prod {A B : Type}
        `{Decidable A} `{Decidable B}
-: Decidable (A * B).
+: Decidable@{k} (A * B).
 Proof.
   destruct (dec A) as [x1|y1]; destruct (dec B) as [x2|y2].
-  - exact (inl (x1,x2)).
-  - apply inr; intros [_ x2]; exact (y2 x2).
-  - apply inr; intros [x1 _]; exact (y1 x1).
-  - apply inr; intros [x1 _]; exact (y1 x1).
+  - exact (inl@{k k} (x1,x2)).
+  - apply inr@{k k}; intros [_ x2]; exact (y2 x2).
+  - apply inr@{k k}; intros [x1 _]; exact (y1 x1).
+  - apply inr@{k k}; intros [x1 _]; exact (y1 x1).
 Defined.
 
 (** Interaction of ap and uncurry *)
diff --git a/theories/Types/Sigma.v b/theories/Types/Sigma.v
index 65b7cf341dc..624a1ea616e 100644
--- a/theories/Types/Sigma.v
+++ b/theories/Types/Sigma.v
@@ -613,7 +613,7 @@ Global Instance istrunc_sigma `{P : A -> Type}
 : IsTrunc n (sig P) | 100.
 Proof.
   generalize dependent A.
-  induction n; simpl; intros A P ac Pc.
+  simple_induction' n; simpl; intros A P ac Pc.
   { apply (Build_Contr _ (center A; center (P (center A)))).
     intros [a ?].
     refine (path_sigma' P (contr a) (path_contr _ _)). }
diff --git a/theories/Types/Sum.v b/theories/Types/Sum.v
index 864573cc080..bcb67b10880 100644
--- a/theories/Types/Sum.v
+++ b/theories/Types/Sum.v
@@ -4,11 +4,13 @@
 Require Import HoTT.Basics.
 Require Import Types.Empty Types.Unit Types.Prod Types.Sigma.
 (** The following are only required for the equivalence between [sum] and a sigma type *)
-Require Import Types.Bool Types.Forall.
+Require Import Types.Bool.
 
 Local Open Scope trunc_scope.
 Local Open Scope path_scope.
 
+Local Set Universe Minimization ToSet.
+
 Generalizable Variables X A B f g n.
 
 Scheme sum_ind := Induction for sum Sort Type.
@@ -31,16 +33,19 @@ Definition eta_sum `(z : A + B) : match z with
 
 (** ** Paths *)
 
-Definition path_sum {A B : Type} (z z' : A + B)
-           (pq : match z, z' with
-                   | inl z0, inl z'0 => z0 = z'0
-                   | inr z0, inr z'0 => z0 = z'0
-                   | _, _ => Empty
-                 end)
-: z = z'.
+Definition code_sum {A B} (z z' : A + B) : Type
+  := match z, z' with
+    | inl a, inl a' => a = a'
+    | inr b, inr b' => b = b'
+    | _, _ => Empty end.
+
+Definition path_sum {A B : Type} {z z' : A + B} (c : code_sum z z') : z = z'.
+Proof.
   destruct z, z'.
-  all:try apply ap, pq.
-  all:elim pq.
+  - apply ap, c.
+  - elim c.
+  - elim c.
+  - apply ap, c.
 Defined.
 
 Definition path_sum_inv {A B : Type} {z z' : A + B}
@@ -77,12 +82,12 @@ Definition path_sum_inr (A : Type) {B : Type} {x x' : B}
 (** This lets us identify the path space of a sum type, up to equivalence. *)
 
 Definition eisretr_path_sum {A B} {z z' : A + B}
-: (path_sum z z') o (@path_sum_inv _ _ z z') == idmap
+  : path_sum o (@path_sum_inv _ _ z z') == idmap
   := fun p => match p as p in (_ = z') return
-                    path_sum z z' (path_sum_inv p) = p
+                    path_sum (path_sum_inv p) = p
               with
                 | 1 => match z as z return
-                             path_sum z z (path_sum_inv 1) = 1
+                             (@path_sum _ _ z z) (path_sum_inv 1) = 1
                        with
                          | inl _ => 1
                          | inr _ => 1
@@ -90,24 +95,20 @@ Definition eisretr_path_sum {A B} {z z' : A + B}
               end.
 
 Definition eissect_path_sum {A B} {z z' : A + B}
-: (@path_sum_inv _ _ z z') o (path_sum z z') == idmap.
+  : path_sum_inv o (@path_sum _ _ z z') == idmap.
 Proof.
   intro p.
   destruct z, z', p; exact idpath.
 Defined.
 
 Global Instance isequiv_path_sum {A B : Type} {z z' : A + B}
-: IsEquiv (path_sum z z') | 0.
+: IsEquiv (@path_sum _ _ z z') | 0.
 Proof.
-  refine (Build_IsEquiv _ _
-                       (path_sum z z')
-                       (@path_sum_inv _ _ z z')
-                       (@eisretr_path_sum A B z z')
-                       (@eissect_path_sum A B z z')
-                       _).
+  refine (Build_IsEquiv _ _ path_sum path_sum_inv
+    eisretr_path_sum eissect_path_sum _).
   destruct z, z';
-    intros [];
-    exact idpath.
+  intros [];
+  exact idpath.
 Defined.
 
 Definition equiv_path_sum {A B : Type} (z z' : A + B)
@@ -357,6 +358,26 @@ Section FunctorSum.
   Definition functor_sum : A + B -> A' + B'
     := fun z => match z with inl z' => inl (f z') | inr z' => inr (g z') end.
 
+  Definition functor_code_sum {z z' : A + B} (c : code_sum z z')
+    : code_sum (functor_sum z) (functor_sum z').
+  Proof.
+    destruct z, z'.
+    - destruct c. reflexivity.
+    - elim c.
+    - elim c.
+    - destruct c. reflexivity.
+  Defined.
+
+  Definition ap_functor_sum {z z' : A + B} (c : code_sum z z')
+    : ap functor_sum (path_sum c) = path_sum (functor_code_sum c).
+  Proof.
+    destruct z, z'.
+    - destruct c. reflexivity.
+    - elim c.
+    - elim c.
+    - destruct c. reflexivity.
+  Defined.
+
   (** The fibers of [functor_sum] are those of [f] and [g]. *)
   Definition hfiber_functor_sum_l (a' : A')
   : hfiber functor_sum (inl a') <~> hfiber f a'.
@@ -584,6 +605,10 @@ Definition equiv_functor_sum_r {A A' B : Type} (f : A <~> A')
 : A + B <~> A' + B
   := f +E 1.
 
+Definition iff_functor_sum {A A' B B' : Type} (f : A <-> A') (g : B <-> B')
+  : A + B <-> A' + B'
+  := (functor_sum (fst f) (fst g), functor_sum (snd f) (snd g)).
+
 (** ** Unfunctoriality on equivalences *)
 
 Global Instance isequiv_unfunctor_sum_l {A A' B B' : Type}
@@ -663,7 +688,8 @@ Definition equiv_unfunctor_sum {A A' B B' : Type}
 
 (* This is a special property of [sum], of course, not an instance of a general family of facts about types. *)
 
-Definition equiv_sum_symm (A B : Type) : A + B <~> B + A.
+Definition equiv_sum_symm@{u v k | u <= k, v <= k} (A : Type@{u}) (B : Type@{v})
+  : Equiv@{k k} (A + B) (B + A).
 Proof.
   apply (equiv_adjointify
            (fun ab => match ab with inl a => inr a | inr b => inl b end)
@@ -686,44 +712,31 @@ Defined.
 
 (** ** Identity *)
 
-Definition sum_empty_l (A : Type) : Empty + A <~> A.
+Definition sum_empty_l@{u|} (A : Type@{u}) : Equiv@{u u} (Empty + A) A.
 Proof.
-  refine (equiv_adjointify
-       (fun z => match z:Empty+A with
-                   | inl e => match e with end
-                   | inr a => a
-                 end)
-       inr (fun a => 1) _).
-  intros [e|z]; [ elim e | reflexivity ].
+  snrapply equiv_adjointify@{u u}.
+  - intros [e|a]; [ exact (Empty_rec@{u} e) | exact a ].
+  - intros a; exact (inr@{Set u} a).
+  - intro x; exact idpath@{u}.
+  - intros [e|z]; [ elim e | exact idpath@{u}].
 Defined.
 
-Definition sum_empty_r (A : Type) : A + Empty <~> A.
-Proof.
-  refine (equiv_adjointify
-       (fun z => match z : A + Empty with
-                   | inr e => match e with end
-                   | inl a => a
-                 end)
-       inl (fun a => 1) _).
-  intros [z|e]; [ reflexivity | elim e ].
-Defined.
+Definition sum_empty_r@{u} (A : Type@{u}) : Equiv@{u u} (A + Empty) A
+  := equiv_compose'@{u u u} (sum_empty_l A) (equiv_sum_symm@{u Set u} _ _).
 
 (** ** Distributivity *)
 
 Definition sum_distrib_l A B C
 : A * (B + C) <~> (A * B) + (A * C).
 Proof.
-  refine (Build_Equiv (A * (B + C)) ((A * B) + (A * C))
-            (fun abc => let (a,bc) := abc in
-                        match bc with
-                          | inl b => inl (a,b)
-                          | inr c => inr (a,c)
-                        end) _).
-  simple refine (Build_IsEquiv (A * (B + C)) ((A * B) + (A * C)) _
-            (fun ax => match ax with
-                         | inl (a,b) => (a,inl b)
-                         | inr (a,c) => (a,inr c)
-                       end) _ _ _).
+  snrapply Build_Equiv.
+  2: snrapply Build_IsEquiv.
+  - intros [a [b|c]].
+    + exact (inl@{u u} (a, b)).
+    + exact (inr@{u u} (a, c)).
+  - intros [[a b]|[a c]].
+    + exact (a, inl@{u u} b).
+    + exact (a, inr@{u u} c).
   - intros [[a b]|[a c]]; reflexivity.
   - intros [a [b|c]]; reflexivity.
   - intros [a [b|c]]; reflexivity.
@@ -946,15 +959,15 @@ Defined.
 (** ** Decidability *)
 
 (** Sums preserve decidability *)
-Global Instance decidable_sum {A B : Type}
-       `{Decidable A} `{Decidable B}
-: Decidable (A + B).
+Global Instance decidable_sum@{u v k | u <= k, v <= k} {A : Type@{u}} {B : Type@{v}}
+  `{Decidable A} `{Decidable B}
+  : Decidable@{k} (A + B).
 Proof.
   destruct (dec A) as [x1|y1].
-  - exact (inl (inl x1)).
-  - destruct (dec B) as [x2|y2].
-    + exact (inl (inr x2)).
-    + apply inr; intros z.
+  - exact (inl@{k k} (inl x1)).
+  - destruct (dec@{v} B) as [x2|y2].
+    + exact (inl@{k k} (inr x2)).
+    + apply inr@{k k}; intros z.
       destruct z as [x1|x2].
       * exact (y1 x1).
       * exact (y2 x2).
@@ -969,13 +982,13 @@ Proof.
   - destruct (dec_paths a1 a2) as [p|np].
     + exact (inl (ap inl p)).
     + apply inr; intros p.
-      exact (np ((path_sum _ _)^-1 p)).
-  - exact (inr (path_sum _ _)^-1).
-  - exact (inr (path_sum _ _)^-1).
+      exact (np (path_sum^-1 p)).
+  - exact (inr path_sum^-1).
+  - exact (inr path_sum^-1).
   - destruct (dec_paths b1 b2) as [p|np].
     + exact (inl (ap inr p)).
     + apply inr; intros p.
-      exact (np ((path_sum _ _)^-1 p)).
+      exact (np (path_sum^-1 p)).
 Defined.
 
 (** Because of [ishprop_sum], decidability of an hprop is again an hprop. *)
diff --git a/theories/Types/Universe.v b/theories/Types/Universe.v
index 69e1c36a27b..5dac3f7b4b2 100644
--- a/theories/Types/Universe.v
+++ b/theories/Types/Universe.v
@@ -43,7 +43,7 @@ Definition path_universe_uncurried {A B : Type} (f : A <~> B) : A = B
 Definition path_universe {A B : Type} (f : A -> B) {feq : IsEquiv f} : (A = B)
   := path_universe_uncurried (Build_Equiv _ _ f feq).
 
-Global Arguments path_universe {A B}%type_scope f%function_scope {feq}.
+Global Arguments path_universe {A B}%_type_scope f%_function_scope {feq}.
 
 Definition eta_path_universe {A B : Type} (p : A = B)
   : path_universe (equiv_path A B p) = p
diff --git a/theories/Utf8Minimal.v b/theories/Utf8Minimal.v
index 06dc33d1f7b..f2538163009 100644
--- a/theories/Utf8Minimal.v
+++ b/theories/Utf8Minimal.v
@@ -1,5 +1,4 @@
-Require Export HoTT.Basics.Utf8.
-Require Import HoTT.Basics.Overture.
+Require Export Basics.Utf8 Basics.Overture Basics.Iff.
 
 (** * Just enough Utf8/unicode for the Classes library to build, without depending on everything that HoTT.Utf8 depends on. *)
 
diff --git a/theories/WildCat/Adjoint.v b/theories/WildCat/Adjoint.v
index 68d865e06e6..9e44791f872 100644
--- a/theories/WildCat/Adjoint.v
+++ b/theories/WildCat/Adjoint.v
@@ -112,6 +112,7 @@ Section AdjunctionData.
   Proof.
     snrapply Build_NatEquiv.
     1: intros [x y]; exact (equiv_adjunction adj x y).
+    snrapply Build_Is1Natural.
     intros [a b] [a' b'] [f g] K.
     refine (_ @ ap (fun x : a $-> G b' => x $o f)
       (is1natural_equiv_adjunction_r adj a b b' g K)).
@@ -124,7 +125,7 @@ Section AdjunctionData.
     snrapply Build_NatTrans.
     { hnf. intros x.
       exact (equiv_adjunction adj x (F x) (Id _)). }
-    hnf.
+    snrapply Build_Is1Natural.
     intros x x' f.
     apply GpdHom_path.
     refine (_^ @ _ @ _).
@@ -142,7 +143,7 @@ Section AdjunctionData.
     snrapply Build_NatTrans.
     { hnf. intros y.
       exact ((equiv_adjunction adj (G y) y)^-1 (Id _)). }
-    hnf.
+    snrapply Build_Is1Natural.
     intros y y' f.
     apply GpdHom_path.
     refine (_^ @ _ @ _).
@@ -334,7 +335,8 @@ Proof.
   - snrapply Build_NatTrans.
     + intros K.
       exact (nattrans_prewhisker (adjunction_unit adj) K).
-    + intros K K' θ j.
+    + snrapply Build_Is1Natural.
+      intros K K' θ j.
       apply GpdHom_path.
       refine (_ @ is1natural_natequiv (natequiv_inverse
         (natequiv_adjunction_r adj _)) _ _ _ _).
@@ -346,7 +348,8 @@ Proof.
   - snrapply Build_NatTrans.
     + intros K.
       exact (nattrans_prewhisker (adjunction_counit adj) K).
-    + intros K K' θ j.
+    + snrapply Build_Is1Natural.
+      intros K K' θ j.
       apply GpdHom_path.
       refine (_ @ is1natural_natequiv
         (natequiv_adjunction_r adj _) _ _ _ _).
@@ -388,7 +391,7 @@ Proof.
   snrapply Build_Adjunction_natequiv_nat_right.
   { intros y.
     refine (natequiv_compose (natequiv_adjunction_l adj _) _).
-    rapply (natequiv_postwhisker _ (natequiv_op _ _ e)). }
+    rapply (natequiv_postwhisker _ (natequiv_op e)). }
   intros x.
   rapply is1natural_comp.
 Defined.
diff --git a/theories/WildCat/Bifunctor.v b/theories/WildCat/Bifunctor.v
index e940a5d19fe..f6625ba4560 100644
--- a/theories/WildCat/Bifunctor.v
+++ b/theories/WildCat/Bifunctor.v
@@ -1,87 +1,486 @@
 Require Import Basics.Overture Basics.Tactics.
-Require Import Types.Forall.
-Require Import WildCat.Core WildCat.Opposite WildCat.Universe WildCat.Prod.
+Require Import Types.Forall Types.Prod.
+Require Import WildCat.Core WildCat.Prod WildCat.Equiv WildCat.NatTrans
+  WildCat.Square WildCat.Opposite.
 
 (** * Bifunctors between WildCats *)
 
-Class IsBifunctor {A B C : Type} `{IsGraph A, IsGraph B, Is1Cat C}
-  (F : A -> B -> C)
-  := {
-    bifunctor_isfunctor_10 : forall a, Is0Functor (F a);
-    bifunctor_isfunctor_01 :
-    forall b, Is0Functor (flip F b);
-    bifunctor_isbifunctor :
-    forall a0 a1 (f : a0 $-> a1) b0 b1 (g : b0 $-> b1),
-      fmap (F _) g $o fmap (flip F _) f $==
-        fmap (flip F _) f $o fmap (F _) g
-  }.
+(** ** Definition *)
 
-#[export] Existing Instance bifunctor_isfunctor_10.
-#[export] Existing Instance bifunctor_isfunctor_01.
-Arguments bifunctor_isbifunctor {A B C} {_ _ _ _ _ _}
-  F {_} {a0 a1} f {b0 b1} g.
+(** We choose to store redundant information in the class, so that depending on how an instance is constructed, we will get the expected implementations of [fmap10], [fmap01] and [fmap11]. *)
+Class Is0Bifunctor {A B C : Type}
+  `{IsGraph A, IsGraph B, IsGraph C} (F : A -> B -> C) := {
+  is0functor_bifunctor_uncurried :: Is0Functor (uncurry F);
+  is0functor01_bifunctor :: forall a, Is0Functor (F a);
+  is0functor10_bifunctor :: forall b, Is0Functor (flip F b);
+}.
 
-Definition bifunctor_hom {C : Type} `{IsGraph C}
-  : C^op -> C -> Type := @Hom C _.
+Arguments Is0Bifunctor {A B C _ _ _} F.
+Arguments is0functor_bifunctor_uncurried {A B C _ _ _} F {_}.
+Arguments is0functor01_bifunctor {A B C _ _ _} F {_} a : rename.
+Arguments is0functor10_bifunctor {A B C _ _ _} F {_} b : rename.
 
-Local Instance is0functor_hom01 {C : Type} `{Is1Cat C}
-  : forall c, Is0Functor (bifunctor_hom c).
+(** We provide two alternate constructors, allowing the user to provide just the first field or the last two fields. *)
+Definition Build_Is0Bifunctor' {A B C : Type}
+  `{Is01Cat A, Is01Cat B, IsGraph C} (F : A -> B -> C)
+  `{!Is0Functor (uncurry F)}
+  : Is0Bifunctor F.
 Proof.
-  intro c; srapply Build_Is0Functor.
-  rapply cat_postcomp.
+  snrapply Build_Is0Bifunctor.
+  - exact _.
+  - exact (is0functor_functor_uncurried01 (uncurry F)).
+  - exact (is0functor_functor_uncurried10 (uncurry F)).
 Defined.
 
-Local Instance is0functor_hom10 {C : Type} `{Is1Cat C}
-  : forall c, Is0Functor (flip bifunctor_hom c).
+Definition Build_Is0Bifunctor'' {A B C : Type}
+  `{IsGraph A, IsGraph B, Is01Cat C} (F : A -> B -> C)
+  `{!forall a, Is0Functor (F a), !forall b, Is0Functor (flip F b)}
+  : Is0Bifunctor F.
 Proof.
-  intro c; srapply Build_Is0Functor.
-  intros ? ? f; cbn.
-  rapply cat_precomp.
-  exact f.
+  (* The first condition follows from [is0functor_prod_is0functor]. *)
+  nrapply Build_Is0Bifunctor; exact _.
 Defined.
 
-(** [Hom] is a bifunctor whenever [C] is a strong 1-category. *)
-Global Instance isbifunctor_hom {C : Type} `{Is1Cat_Strong C}
-  : IsBifunctor (bifunctor_hom (C:=C)).
+(** *** 1-functorial action *)
+
+(** [fmap] in the first argument. *)
+Definition fmap10 {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C}
+  (F : A -> B -> C) `{!Is0Bifunctor F} {a0 a1 : A} (f : a0 $-> a1) (b : B)
+  : (F a0 b) $-> (F a1 b)
+  := fmap (flip F b) f.
+
+(** [fmap] in the second argument. *)
+Definition fmap01 {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C}
+  (F : A -> B -> C) `{!Is0Bifunctor F} (a : A) {b0 b1 : B} (g : b0 $-> b1)
+  : F a b0 $-> F a b1
+  := fmap (F a) g.
+
+(** [fmap] in both arguments. *)
+Definition fmap11 {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C}
+  (F : A -> B -> C) `{!Is0Bifunctor F} {a0 a1 : A} (f : a0 $-> a1)
+  {b0 b1 : B} (g : b0 $-> b1)
+  : F a0 b0 $-> F a1 b1
+  := fmap_pair (uncurry F) f g.
+
+(** As with [Is0Bifunctor], we store redundant information.  In addition, we store the proofs that they are consistent with each other. *)
+Class Is1Bifunctor {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C) `{!Is0Bifunctor F} := {
+
+  is1functor_bifunctor_uncurried :: Is1Functor (uncurry F);
+  is1functor01_bifunctor :: forall a, Is1Functor (F a);
+  is1functor10_bifunctor :: forall b, Is1Functor (flip F b);
+
+  fmap11_is_fmap01_fmap10 {a0 a1} (f : a0 $-> a1) {b0 b1} (g : b0 $-> b1)
+    : fmap11 F f g $== fmap01 F a1 g $o fmap10 F f b0;
+  fmap11_is_fmap10_fmap01 {a0 a1} (f : a0 $-> a1) {b0 b1} (g : b0 $-> b1)
+    : fmap11 F f g $== fmap10 F f b1 $o fmap01 F a0 g;
+}.
+
+Arguments Is1Bifunctor {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {Is0Bifunctor} : rename.
+Arguments Build_Is1Bifunctor {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {_} _ _ _ _ _.
+Arguments is1functor_bifunctor_uncurried {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {_ _}.
+Arguments is1functor01_bifunctor {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {_ _} a : rename.
+Arguments is1functor10_bifunctor {A B C _ _ _ _ _ _ _ _ _ _ _ _} F {_ _} b : rename.
+Arguments fmap11_is_fmap01_fmap10 {A B C _ _ _ _ _ _ _ _ _ _ _ _} F
+  {Is0Bifunctor Is1Bifunctor} {a0 a1} f {b0 b1} g : rename.
+Arguments fmap11_is_fmap10_fmap01 {A B C _ _ _ _ _ _ _ _ _ _ _ _} F
+  {Is0Bifunctor Is1Bifunctor} {a0 a1} f {b0 b1} g : rename.
+
+(** We again provide two alternate constructors. *)
+Definition Build_Is1Bifunctor' {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C)
+  `{!Is0Functor (uncurry F), !Is1Functor (uncurry F)}
+  : Is1Bifunctor (Is0Bifunctor := Build_Is0Bifunctor' F) F.
+Proof.
+  snrapply Build_Is1Bifunctor.
+  - exact _.
+  - exact (is1functor_functor_uncurried01 (uncurry F)).
+  - exact (is1functor_functor_uncurried10 (uncurry F)).
+  - intros a0 a1 f b0 b1 g.
+    refine (_^$ $@ fmap_pair_comp (uncurry F) f (Id b0) (Id a1) g).
+    exact (fmap2_pair (uncurry F) (cat_idl _) (cat_idr _)).
+  - intros a0 a1 f b0 b1 g.
+    refine (_^$ $@ fmap_pair_comp (uncurry F) (Id a0) g f (Id b1)).
+    exact (fmap2_pair (uncurry F) (cat_idr _) (cat_idl _)).
+Defined.
+
+Definition Build_Is1Bifunctor'' {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A -> B -> C)
+  `{!forall a, Is0Functor (F a), !forall b, Is0Functor (flip F b)}
+  (Is0Bifunctor_F := Build_Is0Bifunctor'' F)
+  `{!forall a, Is1Functor (F a), !forall b, Is1Functor (flip F b)}
+  (bifunctor_coh : forall a0 a1 (f : a0 $-> a1) b0 b1 (g : b0 $-> b1),
+    fmap01 F a1 g $o fmap10 F f b0 $== fmap10 F f b1 $o fmap01 F a0 g)
+  : Is1Bifunctor F.
 Proof.
-  srapply Build_IsBifunctor.
-  intros ? ? f ? ? g x; cbn.
-  unfold cat_precomp, cat_postcomp.
-  symmetry; apply cat_assoc_strong.
+  snrapply Build_Is1Bifunctor.
+  - exact _. (* [is1functor_prod_is1functor]. *)
+  - exact _.
+  - exact _.
+  - intros a0 a1 f b0 b1 g.
+    exact (bifunctor_coh a0 a1 f b0 b1 g)^$.
+  - reflexivity.
 Defined.
 
-Definition fmap01 {A B C : Type} `{Is01Cat A, Is01Cat B, Is1Cat C}
-  (F : A -> B -> C) `{!IsBifunctor F}
+(** ** Bifunctor lemmas *)
+
+(** *** Coherence *)
+
+Definition bifunctor_coh {A B C : Type}
+  (F : A -> B -> C) `{Is1Bifunctor A B C F}
+  {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} (g : b0 $-> b1)
+  : fmap01 F a1 g $o fmap10 F f b0 $== fmap10 F f b1 $o fmap01 F a0 g
+  := (fmap11_is_fmap01_fmap10 _ _ _)^$ $@ fmap11_is_fmap10_fmap01 _ _ _.
+
+(** 2-functorial action *)
+
+Definition fmap02 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (a : A) {b0 b1 : B} {g g' : b0 $-> b1} (q : g $== g')
+  : fmap01 F a g $== fmap01 F a g'
+  := fmap2 (F a) q.
+
+Definition fmap12 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} {g g' : b0 $-> b1} (q : g $== g')
+  : fmap11 F f g $== fmap11 F f g'
+  := fmap2_pair (uncurry F) (Id _) q.
+
+Definition fmap20 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} {f f' : a0 $-> a1} (p : f $== f') (b : B)
+  : fmap10 F f b $== fmap10 F f' b
+  := fmap2 (flip F b) p.
+
+Definition fmap21 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} {f f' : a0 $-> a1} (p : f $== f') {b0 b1 : B} (g : b0 $-> b1)
+  : fmap11 F f g $== fmap11 F f' g
+  := fmap2_pair (uncurry F) p (Id _).
+
+Definition fmap22 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} {f f' : a0 $-> a1} (p : f $== f')
+  {b0 b1 : B} {g g' : b0 $-> b1} (q : g $== g')
+  : fmap11 F f g $== fmap11 F f' g'
+  := fmap2_pair (uncurry F) p q.
+
+(** *** Identity preservation *)
+
+Definition fmap01_id {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) (b : B)
+  : fmap01 F a (Id b) $== Id (F a b)
+  := fmap_id (F a) b.
+
+Definition fmap10_id {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) (b : B)
+  : fmap10 F (Id a) b $== Id (F a b)
+  := fmap_id (flip F b) a.
+
+Definition fmap11_id {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F} (a : A) (b : B)
+  : fmap11 F (Id a) (Id b) $== Id (F a b)
+  := fmap_id (uncurry F) (a, b).
+
+(** [fmap11] with left map the identity gives [fmap01]. *)
+Definition fmap01_is_fmap11 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
   (a : A) {b0 b1 : B} (g : b0 $-> b1)
-  : F a b0 $-> F a b1 := fmap (F a) g.
+  : fmap11 F (Id a) g $== fmap01 F a g
+  := fmap11_is_fmap01_fmap10 _ _ _ $@ (_ $@L fmap10_id _ _ _) $@ cat_idr _.
 
-Definition fmap10 {A B C : Type} `{Is01Cat A, Is01Cat B, Is1Cat C}
-  (F : A -> B -> C) `{!IsBifunctor F}
+(** [fmap11] with right map the identity gives [fmap10]. *)
+Definition fmap10_is_fmap11 {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
   {a0 a1 : A} (f : a0 $-> a1) (b : B)
-  : (F a0 b) $-> (F a1 b) := fmap (flip F b) f.
+  : fmap11 F f (Id b) $== fmap10 F f b
+  := fmap11_is_fmap01_fmap10 _ _ _ $@ (fmap01_id _ _ _ $@R _) $@ cat_idl _.
+
+(** *** Composition preservation *)
+
+Definition fmap01_comp {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (a : A) {b0 b1 b2 : B} (g : b1 $-> b2) (f : b0 $-> b1)
+  : fmap01 F a (g $o f) $== fmap01 F a g $o fmap01 F a f
+  := fmap_comp (F a) f g.
+
+Definition fmap10_comp {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 a2 : A} (g : a1 $-> a2) (f : a0 $-> a1) (b : B)
+  : fmap10 F (g $o f) b $== fmap10 F g b $o fmap10 F f b
+  := fmap_comp (flip F b) f g.
+
+Definition fmap11_comp {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 a2 : A} (g : a1 $-> a2) (f : a0 $-> a1)
+  {b0 b1 b2 : B} (k : b1 $-> b2) (h : b0 $-> b1)
+  : fmap11 F (g $o f) (k $o h) $== fmap11 F g k $o fmap11 F f h
+  := fmap_pair_comp (uncurry F) _ _ _ _.
+
+(** *** Equivalence preservation *)
+
+Global Instance iemap10 {A B C : Type} `{HasEquivs A, Is1Cat B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} (f : a0 $<~> a1) (b : B)
+  : CatIsEquiv (fmap10 F f b)
+  := iemap (flip F b) f.
+
+Global Instance iemap01 {A B C : Type} `{Is1Cat A, HasEquivs B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (a : A) {b0 b1 : B} (g : b0 $<~> b1)
+  : CatIsEquiv (fmap01 F a g)
+  := iemap (F a) g.
+
+Global Instance iemap11 {A B C : Type} `{HasEquivs A, HasEquivs B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} (f : a0 $<~> a1) {b0 b1 : B} (g : b0 $<~> b1)
+  : CatIsEquiv (fmap11 F f g)
+  := iemap (uncurry F) (a := (a0, b0)) (b := (_, _)) (f, g).
+
+Definition emap10 {A B C : Type} `{HasEquivs A, Is1Cat B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} (f : a0 $<~> a1) (b : B)
+  : F a0 b $<~> F a1 b
+  := Build_CatEquiv (fmap10 F f b).
+
+Definition emap01 {A B C : Type} `{Is1Cat A, HasEquivs B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (a : A) {b0 b1 : B} (g : b0 $<~> b1)
+  : F a b0 $<~> F a b1
+  := Build_CatEquiv (fmap01 F a g).
+
+Definition emap11 {A B C : Type} `{HasEquivs A, HasEquivs B, HasEquivs C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a0 a1 : A} (f : a0 $<~> a1) {b0 b1 : B} (g : b0 $<~> b1)
+  : F a0 b0 $<~> F a1 b1
+  := Build_CatEquiv (fmap11 F f g).
+
+(** ** Flipping bifunctors *)
+
+Definition is0bifunctor_flip {A B C : Type}
+  (F : A -> B -> C) `{Is01Cat A, Is01Cat B, Is01Cat C, !Is0Bifunctor F}
+  : Is0Bifunctor (flip F).
+Proof.
+  snrapply Build_Is0Bifunctor.
+  - change (Is0Functor (uncurry F o equiv_prod_symm _ _)).
+    exact _.
+  - exact _.
+  - exact _.
+Defined.
+Hint Immediate is0bifunctor_flip : typeclass_instances.
 
-Global Instance isbifunctor_compose {A B C D : Type}
-  `{IsGraph A, IsGraph B, Is1Cat C, Is1Cat D}
+Definition is1bifunctor_flip {A B C : Type}
+(F : A -> B -> C) `{H : Is1Bifunctor A B C F}
+  : Is1Bifunctor (flip F).
+Proof.
+  snrapply Build_Is1Bifunctor.
+  - change (Is1Functor (uncurry F o equiv_prod_symm _ _)).
+    exact _.
+  - exact _.
+  - exact _.
+  - intros b0 b1 g a0 a1 f.
+    exact (fmap11_is_fmap10_fmap01 F f g).
+  - intros b0 b1 g a0 a1 f.
+    exact (fmap11_is_fmap01_fmap10 F f g).
+Defined.
+Hint Immediate is1bifunctor_flip : typeclass_instances.
+
+(** ** Composition of bifunctors *)
+
+(** There are 4 different ways to compose a functor with a bifunctor. *)
+
+(** Restricting a functor along a bifunctor yields a bifunctor. *)
+Global Instance is0bifunctor_postcompose {A B C D : Type}
+  `{IsGraph A, IsGraph B, IsGraph C, IsGraph D}
+  (F : A -> B -> C) {bf : Is0Bifunctor F}
+  (G : C -> D) `{!Is0Functor G}
+  : Is0Bifunctor (fun a b => G (F a b)) | 10
+  := {}.
+
+Global Instance is1bifunctor_postcompose {A B C D : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C, Is1Cat D}
   (F : A -> B -> C) (G : C -> D) `{!Is0Functor G, !Is1Functor G}
-  `{P : !IsBifunctor F}
-  : IsBifunctor (fun a b => G (F a b)).
+  `{!Is0Bifunctor F} {bf : Is1Bifunctor F}
+  : Is1Bifunctor (fun a b => G (F a b)) | 10.
+Proof.
+  snrapply Build_Is1Bifunctor.
+  1-3: exact _.
+  - intros a0 a1 f b0 b1 g.
+    exact (fmap2 G (fmap11_is_fmap01_fmap10 F f g) $@ fmap_comp G _ _).
+  - intros a0 a1 f b0 b1 g.
+    exact (fmap2 G (fmap11_is_fmap10_fmap01 F f g) $@ fmap_comp G _ _).
+Defined.
+
+Global Instance is0bifunctor_precompose {A B C D E : Type}
+  `{IsGraph A, IsGraph B, IsGraph C, IsGraph D, IsGraph E}
+  (G : A -> B) (K : E -> C) (F : B -> C -> D)
+  `{!Is0Functor G, !Is0Bifunctor F, !Is0Functor K}
+  : Is0Bifunctor (fun a b => F (G a) (K b)) | 10.
+Proof.
+  snrapply Build_Is0Bifunctor.
+  - change (Is0Functor (uncurry F o functor_prod G K)).
+    exact _.
+  - exact _.
+  - intros e.
+    change (Is0Functor (flip F (K e) o G)).
+    exact _.
+Defined.
+
+Global Instance is1bifunctor_precompose {A B C D E : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C, Is1Cat D, Is1Cat E}
+  (G : A -> B) (K : E -> C) (F : B -> C -> D)
+  `{!Is0Functor G, !Is1Functor G, !Is0Bifunctor F, !Is1Bifunctor F,
+    !Is0Functor K, !Is1Functor K}
+  : Is1Bifunctor (fun a b => F (G a) (K b)) | 10.
+Proof.
+  snrapply Build_Is1Bifunctor.
+  - change (Is1Functor (uncurry F o functor_prod G K)).
+    exact _.
+  - exact _.
+  - intros e.
+    change (Is1Functor (flip F (K e) o G)).
+    exact _.
+  - intros a0 a1 f b0 b1 g.
+    exact (fmap11_is_fmap01_fmap10 F (fmap G f) (fmap K g)).
+  - intros a0 a1 f b0 b1 g.
+    exact (fmap11_is_fmap10_fmap01 F (fmap G f) (fmap K g)).
+Defined.
+
+Global Instance is0functor_uncurry_uncurry_left {A B C D E}
+  (F : A -> B -> C) (G : C -> D -> E)
+  `{IsGraph A, IsGraph B, IsGraph C, IsGraph D, IsGraph E,
+    !Is0Bifunctor F, !Is0Bifunctor G}
+  : Is0Functor (uncurry (uncurry (fun x y z => G (F x y) z))).
+Proof.
+  exact _.
+Defined.
+
+Global Instance is1functor_uncurry_uncurry_left {A B C D E}
+  (F : A -> B -> C) (G : C -> D -> E)
+  `{Is1Cat A, Is1Cat B, Is1Cat C, Is1Cat D, Is1Cat E,
+    !Is0Bifunctor F, !Is1Bifunctor F, !Is0Bifunctor G, !Is1Bifunctor G}
+  : Is1Functor (uncurry (uncurry (fun x y z => G (F x y) z))).
+Proof.
+  exact _.
+Defined.
+
+Global Instance is0functor_uncurry_uncurry_right {A B C D E}
+  (F : A -> B -> D) (G : C -> D -> E)
+  `{IsGraph A, IsGraph B, IsGraph C, IsGraph D, IsGraph E,
+    !Is0Bifunctor F, !Is0Bifunctor G}
+  : Is0Functor (uncurry (uncurry (fun x y z => G x (F y z)))).
+Proof.
+  snrapply Build_Is0Functor.
+  intros cab cab' [[h f] g].
+  exact (fmap11 G h (fmap11 F f g)).
+Defined.
+
+Global Instance is1functor_uncurry_uncurry_right {A B C D E}
+  (F : A -> B -> D) (G : C -> D -> E)
+  `{Is1Cat A, Is1Cat B, Is1Cat C, Is1Cat D, Is1Cat E,
+    !Is0Bifunctor F, !Is1Bifunctor F, !Is0Bifunctor G, !Is1Bifunctor G}
+  : Is1Functor (uncurry (uncurry (fun x y z => G x (F y z)))).
 Proof.
-  srapply Build_IsBifunctor.
-  intros ? ? f ? ? g; cbn.
-  refine ((fmap_comp G _ _)^$ $@ _ $@ fmap_comp G _ _).
-  rapply fmap2.
-  apply P.
+  snrapply Build_Is1Functor.
+  - intros cab cab' [[h f] g] [[h' f'] g'] [[q p] r].
+    exact (fmap22 G q (fmap22 F p r)).
+  - intros cab.
+    exact (fmap12 G _ (fmap11_id F _ _) $@ fmap11_id G _ _).
+  - intros cab cab' cab'' [[h f] g] [[h' f'] g'].
+    exact (fmap12 G _ (fmap11_comp F _ _ _ _) $@ fmap11_comp G _ _ _ _).
+Defined.  
+
+Definition fmap11_square {A B C : Type} `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {a00 a20 a02 a22 : A} {f10 : a00 $-> a20} {f12 : a02 $-> a22}
+  {f01 : a00 $-> a02} {f21 : a20 $-> a22}
+  {b00 b20 b02 b22 : B} {g10 : b00 $-> b20} {g12 : b02 $-> b22}
+  {g01 : b00 $-> b02} {g21 : b20 $-> b22}
+  (p : Square f01 f21 f10 f12) (q : Square g01 g21 g10 g12)
+  : Square (fmap11 F f01 g01) (fmap11 F f21 g21) (fmap11 F f10 g10) (fmap11 F f12 g12)
+  := (fmap11_comp F _ _ _ _)^$ $@ fmap22 F p q $@ fmap11_comp F _ _ _ _.
+
+(** ** Natural transformations between bifunctors *)
+
+(** We can show that an uncurried natural transformation between uncurried bifunctors by composing the naturality square in each variable. *)
+Global Instance is1natural_uncurry {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A -> B -> C) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (G : A -> B -> C) `{!Is0Bifunctor G, !Is1Bifunctor G}
+  (alpha : uncurry F $=> uncurry G)
+  (nat_l : forall b, Is1Natural (flip F b) (flip G b) (fun x : A => alpha (x, b)))
+  (nat_r : forall a, Is1Natural (F a) (G a) (fun y : B => alpha (a, y)))
+  : Is1Natural (uncurry F) (uncurry G) alpha.
+Proof.
+  snrapply Build_Is1Natural.
+  intros [a b] [a' b'] [f f']; cbn in *.
+  change (?w $o ?x $== ?y $o ?z) with (Square z w x y).
+  nrapply vconcatL.
+  1: rapply (fmap11_is_fmap01_fmap10 F).
+  nrapply vconcatR.
+  2: rapply (fmap11_is_fmap01_fmap10 G).
+  exact (hconcat (nat_l _ _ _ f) (nat_r _ _ _ f')).
 Defined.
 
-(** There are two possible ways to define this, which will only agree in the event that F is a bifunctor. *)
-#[export] Instance Is0Functor_uncurry_bifunctor {A B C : Type}
-  `{IsGraph A, IsGraph B, Is1Cat C}
-  (F : A -> B -> C)
-  `{forall a, Is0Functor (F a), forall b, Is0Functor (flip F b)}
-  : Is0Functor (uncurry F).
+(** Flipping a natural transformation between bifunctors. *)
+Definition nattrans_flip {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C}
+  {F : A -> B -> C} `{!Is0Bifunctor F, !Is1Bifunctor F}
+  {G : A -> B -> C} `{!Is0Bifunctor G, !Is1Bifunctor G}
+  : NatTrans (uncurry F) (uncurry G)
+    -> NatTrans (uncurry (flip F)) (uncurry (flip G)).
 Proof.
-  srapply Build_Is0Functor.
-  intros [a1 b1] [a2 b2] [f g]; cbn in f, g.
-  unfold uncurry; cbn.
-  exact ((fmap (flip F b2) f) $o (fmap (F a1) g)).
+  intros alpha.
+  snrapply Build_NatTrans.
+  - exact (alpha o equiv_prod_symm _ _).
+  - snrapply Build_Is1Natural'.
+    + intros [b a] [b' a'] [g f].
+      exact (isnat (a:=(a, b)) (a':=(a', b')) alpha (f, g)).
+    + intros [b a] [b' a'] [g f].
+      exact (isnat_tr (a:=(a, b)) (a':=(a', b')) alpha (f, g)).
 Defined.
+
+(** ** Opposite Bifunctors *)
+
+(** There are a few more combinations we can do for this, such as profunctors, but we will leave those for later. *)
+
+Global Instance is0bifunctor_op A B C (F : A -> B -> C) `{Is0Bifunctor A B C F}
+  : Is0Bifunctor (F : A^op -> B^op -> C^op).
+Proof.
+  snrapply Build_Is0Bifunctor.
+  - exact (is0functor_op _ _ (uncurry F)).
+  - intros a.
+    nrapply is0functor_op.
+    exact (is0functor01_bifunctor F a).
+  - intros b.
+    nrapply is0functor_op.
+    exact (is0functor10_bifunctor F b).
+Defined.
+
+Global Instance is1bifunctor_op A B C (F : A -> B -> C) `{Is1Bifunctor A B C F}
+  : Is1Bifunctor (F : A^op -> B^op -> C^op).
+Proof.
+  snrapply Build_Is1Bifunctor.
+  - exact (is1functor_op _ _ (uncurry F)).
+  - intros a.
+    nrapply is1functor_op.
+    exact (is1functor01_bifunctor F a).
+  - intros b.
+    nrapply is1functor_op.
+    exact (is1functor10_bifunctor F b).
+  - intros a0 a1 f b0 b1 g; cbn in f, g.
+    exact (fmap11_is_fmap10_fmap01 F f g).
+  - intros a0 a1 f b0 b1 g; cbn in f, g.
+    exact (fmap11_is_fmap01_fmap10 F f g).
+Defined.
+
+Global Instance is0bifunctor_op' A B C (F : A^op -> B^op -> C^op)
+  `{IsGraph A, IsGraph B, IsGraph C, Fop : !Is0Bifunctor (F : A^op -> B^op -> C^op)}
+  : Is0Bifunctor (F : A -> B -> C)
+  := is0bifunctor_op A^op B^op C^op F.
+
+Global Instance is1bifunctor_op' A B C (F : A^op -> B^op -> C^op)
+  `{Is1Cat A, Is1Cat B, Is1Cat C,
+    !Is0Bifunctor (F : A^op -> B^op -> C^op), !Is1Bifunctor (F : A^op -> B^op -> C^op)}
+  : Is1Bifunctor (F : A -> B -> C)
+  := is1bifunctor_op A^op B^op C^op F.
diff --git a/theories/WildCat/Coproducts.v b/theories/WildCat/Coproducts.v
index 7904876c830..f1ae1fcb3a5 100644
--- a/theories/WildCat/Coproducts.v
+++ b/theories/WildCat/Coproducts.v
@@ -1,35 +1,178 @@
-Require Import Basics EquivGpd Types.Prod Types.Sum.
-Require Import WildCat.Core WildCat.ZeroGroupoid WildCat.Equiv WildCat.Yoneda WildCat.Universe WildCat.NatTrans WildCat.Opposite WildCat.Products.
+Require Import Basics.Overture Basics.Tactics Basics.Decidable.
+Require Import Types.Bool.
+Require Import WildCat.Core WildCat.Equiv WildCat.Forall WildCat.NatTrans
+               WildCat.Opposite WildCat.Products WildCat.Universe
+               WildCat.Yoneda WildCat.ZeroGroupoid WildCat.PointedCat
+               WildCat.Monoidal WildCat.Bifunctor.
 
 (** * Categories with coproducts *)
 
-Class BinaryCoproduct (A : Type) `{Is1Cat A} (x y : A) :=
-  prod_co_coprod :: BinaryProduct (x : A^op) (y : A^op)
-.
+Definition cat_coprod_rec_inv {I A : Type} `{Is1Cat A}
+  (coprod : A) (x : I -> A) (z : A) (inj : forall i, x i $-> coprod)
+  : yon_0gpd z coprod $-> prod_0gpd I (fun i => yon_0gpd z (x i))
+  := cat_prod_corec_inv (coprod : A^op) x z inj.
 
-Arguments BinaryCoproduct {A _ _ _ _} x y.
+Class Coproduct (I : Type) {A : Type} `{Is1Cat A} (x : I -> A)
+  := prod_co_coprod :: Product (A:=A^op) I x.
 
-Definition cat_coprod {A : Type}  `{Is1Cat  A} (x y : A) `{!BinaryCoproduct x y} : A
-  := cat_prod (x : A^op) y.
+Definition cat_coprod (I : Type) {A : Type} (x : I -> A) `{Coproduct I _ x} : A
+  := cat_prod (A:=A^op) I x.
 
-Definition cat_inl {A : Type} `{Is1Cat A} {x y : A} `{!BinaryCoproduct x y} : x $-> cat_coprod x y.
+Definition cat_in {I : Type} {A : Type} {x : I -> A} `{Coproduct I _ x}
+  : forall (i : I), x i $-> cat_coprod I x
+  := cat_pr (A:=A^op) (x:=x).
+
+Global Instance cat_isequiv_cat_coprod_rec_inv {I : Type} {A : Type}
+  {x : I -> A} `{Coproduct I _ x}
+  : forall (z : A), CatIsEquiv (cat_coprod_rec_inv (cat_coprod I x) x z cat_in)
+  := cat_isequiv_cat_prod_corec_inv (A:=A^op) (x:=x).
+
+(** A convenience wrapper for building coproducts *)
+Definition Build_Coproduct (I : Type) {A : Type} `{Is1Cat A} {x : I -> A}
+  (cat_coprod : A) (cat_in : forall i : I, x i $-> cat_coprod)
+  (cat_coprod_rec : forall z : A,
+    (forall i : I, x i $-> z) -> (cat_coprod $-> z))
+  (cat_coprod_beta_in : forall (z : A) (f : forall i, x i $-> z) (i : I),
+    cat_coprod_rec z f $o cat_in i $== f i)
+  (cat_prod_eta_in : forall (z : A) (f g : cat_coprod $-> z),
+    (forall i : I, f $o cat_in i $== g $o cat_in i) -> f $== g)
+  : Coproduct I x
+  := Build_Product I
+      (cat_coprod : A^op)
+      cat_in
+      cat_coprod_rec
+      cat_coprod_beta_in
+      cat_prod_eta_in.
+
+Section Lemmata.
+  Context (I : Type) {A : Type} {x : I -> A} `{Coproduct I _ x}.
+
+  Definition cate_cat_coprod_rec_inv {z : A}
+    : yon_0gpd z (cat_coprod I x) $<~> prod_0gpd I (fun i => yon_0gpd z (x i))
+    := cate_cat_prod_corec_inv I (A:=A^op) (x:=x).
+
+  Definition cate_cat_coprod_rec {z : A}
+    : prod_0gpd I (fun i => yon_0gpd z (x i)) $<~> yon_0gpd z (cat_coprod I x)
+    := cate_cat_prod_corec I (A:=A^op) (x:=x).
+
+  Definition cat_coprod_rec {z : A}
+    : (forall i, x i $-> z) -> cat_coprod I x $-> z
+    := cat_prod_corec I (A:=A^op) (x:=x).
+
+  Definition cat_coprod_beta {z : A} (f : forall i, x i $-> z)
+    : forall i, cat_coprod_rec f $o cat_in i $== f i
+    := cat_prod_beta I (A:=A^op) (x:=x) f.
+
+  Definition cat_coprod_eta {z : A} (f : cat_coprod I x $-> z)
+    : cat_coprod_rec (fun i => f $o cat_in i) $== f
+    := cat_prod_eta I (A:=A^op) (x:=x) f.
+
+  Definition natequiv_cat_coprod_rec_inv
+    : NatEquiv (fun z => yon_0gpd z (cat_coprod I x))
+      (fun z : A => prod_0gpd I (fun i => yon_0gpd z (x i)))
+    := natequiv_cat_prod_corec_inv I (A:=A^op) (x:=x).
+
+  Definition cat_coprod_rec_eta {z : A} {f g : forall i, x i $-> z}
+    : (forall i, f i $== g i) -> cat_coprod_rec f $== cat_coprod_rec g
+    := cat_prod_corec_eta I (A:=A^op) (x:=x).
+
+  Definition cat_coprod_in_eta {z : A} {f g : cat_coprod I x $-> z}
+    : (forall i, f $o cat_in i $== g $o cat_in i) -> f $== g
+    := cat_prod_pr_eta I (A:=A^op) (x:=x).
+End Lemmata.
+
+(** *** Codiagonal / fold map *)
+
+Definition cat_coprod_codiag {I : Type} {A : Type} (x : A) `{Coproduct I _ (fun _ => x)}
+  : cat_coprod I (fun _ => x) $-> x
+  := cat_prod_diag (A:=A^op) x.
+
+(** *** Uniqueness of coproducts *)
+
+(** [I]-indexed coproducts are unique no matter how they are constructed. *)
+Definition cate_cat_coprod {I J : Type} (ie : I <~> J) {A : Type} `{HasEquivs A}
+  (x : I -> A) `{!Coproduct I x} (y : J -> A) `{!Coproduct J y}
+  (e : forall (i : I), y (ie i) $<~> x i)
+  : cat_coprod J y $<~> cat_coprod I x
+  := cate_cat_prod (A:=A^op) ie x y e.
+
+(** *** Existence of coproducts *)
+
+Class HasCoproducts (I A : Type) `{Is1Cat A}
+  := has_coproducts :: forall x : I -> A, Coproduct I x.
+
+Class HasAllCoproducts (A : Type) `{Is1Cat A}
+  := has_all_coproducts :: forall I : Type, HasCoproducts I A.
+
+(** *** Coproduct functor *)
+
+Local Instance hasproductsop_hascoproducts {I A : Type} `{HasCoproducts I A}
+  : HasProducts I A^op
+  := fun x : I -> A^op => @has_coproducts I A _ _ _ _ _ x.
+
+Global Instance is0functor_cat_coprod (I : Type) `{IsGraph I}
+  (A : Type) `{HasCoproducts I A}
+  : @Is0Functor (I -> A) A (isgraph_forall I (fun _ => A)) _
+    (fun x : I -> A => cat_coprod I x).
 Proof.
-  change (cat_prod (x : A^op) y $-> x).
-  exact cat_pr1.
+  apply is0functor_op'.
+  exact (is0functor_cat_prod I A^op).
 Defined.
 
-Definition cat_inr {A : Type} `{Is1Cat A} {x y : A} `{!BinaryCoproduct x y} : y $-> cat_coprod x y.
+Global Instance is1functor_cat_coprod (I : Type) `{IsGraph I}
+  (A : Type) `{HasCoproducts I A}
+  : @Is1Functor (I -> A) A _ _ _ (is1cat_forall I (fun _ => A)) _ _ _ _
+    (fun x : I -> A => cat_coprod I x) _.
 Proof.
-  change (cat_prod (x : A^op) y $-> y).
-  exact cat_pr2.
+  apply is1functor_op'.
+  exact (is1functor_cat_prod I A^op).
 Defined.
 
+(** *** Categories with specific kinds of coproducts *)
+
+Definition isinitial_coprodempty {A : Type} {z : A}
+  `{Coproduct Empty A (fun _ => z)}
+  : IsInitial (cat_coprod Empty (fun _ => z)).
+Proof.
+  intros a.
+  snrefine (cat_coprod_rec _ _; fun f => cat_coprod_in_eta _ _); intros [].
+Defined.
+
+(** *** Binary coproducts *)
+
+Class BinaryCoproduct {A : Type} `{Is1Cat A} (x y : A)
+  := prod_co_bincoprod :: BinaryProduct (A:=A^op) x y.
+
+Definition cat_bincoprod {A : Type}  `{Is1Cat A} (x y : A) `{!BinaryCoproduct x y} : A
+  := cat_binprod (x : A^op) y.
+
+Definition cat_inl {A : Type} `{Is1Cat A} {x y : A} `{!BinaryCoproduct x y}
+  : x $-> cat_bincoprod x y
+  := cat_pr1 (A:=A^op) (x:=x) (y:=y).
+
+Definition cat_inr {A : Type} `{Is1Cat A} {x y : A} `{!BinaryCoproduct x y}
+  : y $-> cat_bincoprod x y
+  := cat_pr2 (A:=A^op) (x:=x) (y:=y).
+
+(** A category with binary coproducts is a category with a binary coproduct for each pair of objects. *)
+Class HasBinaryCoproducts (A : Type) `{Is1Cat A}
+  := binary_coproducts :: forall x y, BinaryCoproduct x y.
+
+Global Instance hasbinarycoproducts_hascoproductsbool {A : Type}
+  `{HasCoproducts Bool A}
+  : HasBinaryCoproducts A
+  := fun x y => has_coproducts (fun b : Bool => if b then x else y).
+
+(** A convenience wrapper for building binary coproducts *)
 Definition Build_BinaryCoproduct {A : Type} `{Is1Cat A} {x y : A}
   (cat_coprod : A) (cat_inl : x $-> cat_coprod) (cat_inr : y $-> cat_coprod)
   (cat_coprod_rec : forall z : A, (x $-> z) -> (y $-> z) -> cat_coprod $-> z)
-  (cat_coprod_beta_inl : forall z (f : x $-> z) (g : y $-> z), cat_coprod_rec z f g $o cat_inl $== f)
-  (cat_coprod_beta_inr : forall z (f : x $-> z) (g : y $-> z), cat_coprod_rec z f g $o cat_inr $== g)
-  (cat_coprod_in_eta : forall z (f g : cat_coprod $-> z), f $o cat_inl $== g $o cat_inl -> f $o cat_inr $== g $o cat_inr -> f $== g)
+  (cat_coprod_beta_inl : forall (z : A) (f : x $-> z) (g : y $-> z),
+    cat_coprod_rec z f g $o cat_inl $== f)
+  (cat_coprod_beta_inr : forall (z : A) (f : x $-> z) (g : y $-> z),
+    cat_coprod_rec z f g $o cat_inr $== g)
+  (cat_coprod_in_eta : forall (z : A) (f g : cat_coprod $-> z),
+    f $o cat_inl $== g $o cat_inl -> f $o cat_inr $== g $o cat_inr -> f $== g)
   : BinaryCoproduct x y
   := Build_BinaryProduct
       (cat_coprod : A^op)
@@ -41,156 +184,269 @@ Definition Build_BinaryCoproduct {A : Type} `{Is1Cat A} {x y : A}
       cat_coprod_in_eta.
 
 Section Lemmata.
-
   Context {A : Type} {x y z : A} `{BinaryCoproduct _ x y}.
 
-  Definition cate_cat_coprod_rec_inv
-    : (opyon_0gpd (cat_coprod x y) z)
-    $<~> prod_0gpd (opyon_0gpd x z) (opyon_0gpd y z)
-    := @cate_cat_prod_corec_inv A^op x y _ _ _ _ _ _.
+  Definition cat_bincoprod_rec (f : x $-> z) (g : y $-> z)
+    : cat_bincoprod x y $-> z
+    := @cat_binprod_corec A^op _ _ _ _ x y _ _ f g.
 
-  Definition cate_cat_coprod_rec
-    : prod_0gpd (opyon_0gpd x z) (opyon_0gpd y z)
-    $<~> (opyon_0gpd (cat_coprod x y) z)
-    := @cate_cat_prod_corec A^op x y _ _ _ _ _ _.
+  Definition cat_bincoprod_beta_inl (f : x $-> z) (g : y $-> z)
+    : cat_bincoprod_rec f g $o cat_inl $== f
+    := @cat_binprod_beta_pr1 A^op _ _ _ _ x y _ _ f g.
 
-  Definition cat_coprod_rec (f : x $-> z) (g : y $-> z) : cat_coprod x y $-> z
-    := @cat_prod_corec A^op x y _ _ _ _ _ _ f g.
-  
-  Definition cat_coprod_beta_inl (f : x $-> z) (g : y $-> z)
-    : cat_coprod_rec f g $o cat_inl $== f
-    := @cat_prod_beta_pr1 A^op x y _ _ _ _ _ _ f g.
-  
-  Definition cat_coprod_beta_inr (f : x $-> z) (g : y $-> z)
-    : cat_coprod_rec f g $o cat_inr $== g
-    := @cat_prod_beta_pr2 A^op x y _ _ _ _ _ _ f g.
-  
-  Definition cat_coprod_eta (f : cat_coprod x y $-> z)
-    : cat_coprod_rec (f $o cat_inl) (f $o cat_inr) $== f
-    := @cat_prod_eta A^op x y _ _ _ _ _ _ f.
-
-  (* TODO: decompose and move *)
-  Local Instance is0functor_coprod_0gpd_helper
-    : Is0Functor (fun z : A => prod_0gpd (opyon_0gpd x z) (opyon_0gpd y z)).
-  Proof.
-    snrapply Build_Is0Functor.
-    intros a b f.
-    snrapply Build_Morphism_0Gpd.
-    - intros [g g'].
-      exact (f $o g, f $o g').
-    - snrapply Build_Is0Functor.
-      intros [g g'] [h h'] [p q].
-      split.
-      + exact (f $@L p).
-      + exact (f $@L q).
-  Defined.
-
-  (* TODO: decompose and move *)
-  Local Instance is1functor_coprod_0gpd_helper
-    : Is1Functor (fun z : A => prod_0gpd (opyon_0gpd x z) (opyon_0gpd y z)).
-  Proof.
-    snrapply Build_Is1Functor.
-    - intros a b f g p [r_fst r_snd].
-      cbn; split.
-      + refine (_ $@R _).
-        apply p.
-      + refine (_ $@R _).
-        apply p.
-    - intros a [r_fst r_snd].
-      split; apply cat_idl.
-    - intros a b c f g [r_fst r_snd].
-      split; apply cat_assoc.
-  Defined.
+  Definition cat_bincoprod_beta_inr (f : x $-> z) (g : y $-> z)
+    : cat_bincoprod_rec f g $o cat_inr $== g
+    := @cat_binprod_beta_pr2 A^op _ _ _ _ x y _ _ f g.
 
-  Definition natequiv_cat_coprod_rec_inv
-    : NatEquiv (opyon_0gpd (cat_coprod x y)) (fun z => prod_0gpd (opyon_0gpd x z) (opyon_0gpd y z))
-    := @natequiv_cat_prod_corec_inv A^op x y _ _ _ _ _.
+  Definition cat_bincoprod_eta (f : cat_bincoprod x y $-> z)
+    : cat_bincoprod_rec (f $o cat_inl) (f $o cat_inr) $== f
+    := @cat_binprod_eta A^op _ _ _ _ x y _ _ f.
 
-  Definition cat_coprod_rec_eta {f f' : x $-> z} {g g' : y $-> z}
-    : f $== f' -> g $== g' -> cat_coprod_rec f g $== cat_coprod_rec f' g'
-    := @cat_prod_corec_eta A^op x y _ _ _ _ _ _ f f' g g'.
-  
-  Definition cat_coprod_in_eta {f f' : cat_coprod x y $-> z}
-    : f $o cat_inl $== f' $o cat_inl -> f $o cat_inr $== f' $o cat_inr -> f $== f'
-    := @cat_prod_pr_eta A^op x y _ _ _ _ _ _ f f'.
+  Definition cat_bincoprod_eta_in {f g : cat_bincoprod x y $-> z}
+    : f $o cat_inl $== g $o cat_inl -> f $o cat_inr $== g $o cat_inr -> f $== g
+    := @cat_binprod_eta_pr A^op _ _ _ _ x y _ _ f g.
 
+  Definition cat_bincoprod_rec_eta {f f' : x $-> z} {g g' : y $-> z}
+    : f $== f' -> g $== g' -> cat_bincoprod_rec f g $== cat_bincoprod_rec f' g'
+    := @cat_binprod_corec_eta A^op _ _ _ _ x y _ _ f f' g g'.
 End Lemmata.
 
-(** *** Categories with binary coproducts *)
+(** *** Binary coproduct functor *)
 
-Class HasBinaryCoproducts (A : Type) `{Is1Cat A} :=
-  binary_coproducts :: forall x y, BinaryCoproduct x y
-.
+(** Hint: Use [Set Printing Implicit] to see the implicit arguments in the following proofs. *)
 
-(** ** Symmetry of coproducts *)
+Global Instance is0functor_cat_bincoprod_l {A : Type}
+  `{hbc : HasBinaryCoproducts A} y
+  : Is0Functor (A:=A) (fun x => cat_bincoprod x y).
+Proof.
+  rapply is0functor_op'.
+  exact (is0functor_cat_binprod_l (A:=A^op) (H0:=hbc) y).
+Defined.
 
-Definition cate_coprod_swap {A : Type} `{HasEquivs A} {e : HasBinaryCoproducts A} (x y : A)
-  : cat_coprod x y $<~> cat_coprod y x.
+Global Instance is1functor_cat_bincoprod_l {A : Type}
+  `{hbc : HasBinaryCoproducts A} y
+  : Is1Functor (fun x => cat_bincoprod x y).
 Proof.
-  exact (@cate_prod_swap A^op _ _ _ _ _ e _ _).
+  rapply is1functor_op'.
+  exact (is1functor_cat_binprod_l (A:=A^op) (H0:=hbc) y).
 Defined.
 
-(** ** Associativity of coproducts *)
+Global Instance is0functor_cat_bincoprod_r {A : Type}
+  `{hbc : HasBinaryCoproducts A} x
+  : Is0Functor (fun y => cat_bincoprod x y).
+Proof.
+  rapply is0functor_op'.
+  exact (is0functor_cat_binprod_r (A:=A^op) (H0:=hbc) x).
+Defined.
 
-Lemma cate_coprod_assoc {A : Type} `{HasEquivs A} {e : HasBinaryCoproducts A} (x y z : A)
-  : cat_coprod x (cat_coprod y z) $<~> cat_coprod (cat_coprod x y) z.
+Global Instance is1functor_cat_bincoprod_r {A : Type}
+  `{hbc : HasBinaryCoproducts A} x
+  : Is1Functor (fun y => cat_bincoprod x y).
 Proof.
-  exact (@cate_prod_assoc A^op _ _ _ _ _ e x y z)^-1$.
+  rapply is1functor_op'.
+  exact (is1functor_cat_binprod_r (A:=A^op) (H0:=hbc) x).
 Defined.
 
-(** *** Coproduct functor *)
+Global Instance is0bifunctor_cat_bincoprod {A : Type}
+  `{hbc : HasBinaryCoproducts A}
+  : Is0Bifunctor (fun x y => cat_bincoprod x y).
+Proof.
+  nrapply is0bifunctor_op'.
+  exact (is0bifunctor_cat_binprod (A:=A^op) (H0:=hbc)).
+Defined.
 
-(** Hint: Use [Set Printing Implicit] to see the implicit arguments in the following proofs. *)
+Global Instance is1bifunctor_cat_bincoprod {A : Type}
+  `{hbc : HasBinaryCoproducts A}
+  : Is1Bifunctor (fun x y => cat_bincoprod x y).
+Proof.
+  nrapply is1bifunctor_op'.
+  exact (is1bifunctor_cat_binprod (A:=A^op) (H0:=hbc)).
+Defined.
+
+(** *** Products and coproducts in the opposite category *)
+
+Definition hasbinarycoproducts_op_hasbinaryproducts {A : Type}
+  `{hbp : HasBinaryProducts A}
+  : HasBinaryCoproducts A^op
+  := hbp.
+Hint Immediate hasbinarycoproducts_op_hasbinaryproducts : typeclass_instances.
+
+Definition hasbinarycoproducts_hasbinaryproducts_op {A : Type}
+  `{Is1Cat A, hbp : !HasBinaryProducts A^op}
+  : HasBinaryCoproducts A
+  := hbp.
+Hint Immediate hasbinarycoproducts_hasbinaryproducts_op : typeclass_instances.
+
+Definition hasbinaryproducts_op_hasbinarycoproducts {A : Type}
+  `{hbc : HasBinaryCoproducts A}
+  : HasBinaryProducts A^op
+  := hbc.
+Hint Immediate hasbinarycoproducts_op_hasbinaryproducts : typeclass_instances.
 
-Global Instance is0functor_cat_coprod_l {A : Type}
-  `{H0 : HasBinaryCoproducts A} y
-  : Is0Functor (A:=A) (fun x => cat_coprod x y).
+Definition hasbinaryproducts_hasbinarycoproducts_op {A : Type}
+  `{Is1Cat A, hbc : !HasBinaryCoproducts A^op}
+  : HasBinaryProducts A
+  := hbc.
+Hint Immediate hasbinaryproducts_hasbinarycoproducts_op : typeclass_instances.
+
+(** *** Symmetry of coproducts *)
+
+Definition cat_bincoprod_swap {A : Type} `{Is1Cat A}
+  {hbc : HasBinaryCoproducts A} (x y : A)
+  : cat_bincoprod x y $-> cat_bincoprod y x.
 Proof.
-  rapply is0functor_op'.
-  exact (is0functor_cat_prod_l (A:=A^op) (H0:=H0) y).
+  exact (@cat_binprod_swap A^op _ _ _ _ hbc _ _).
 Defined.
 
-Global Instance is1functor_cat_coprod_l {A : Type}
-  `{H0 : HasBinaryCoproducts A} y
-  : Is1Functor (fun x => cat_coprod x y).
+Definition cate_bincoprod_swap {A : Type} `{HasEquivs A}
+  {hbc : HasBinaryCoproducts A} (x y : A)
+  : cat_bincoprod x y $<~> cat_bincoprod y x.
 Proof.
-  rapply is1functor_op'.
-  exact (is1functor_cat_prod_l (A:=A^op) (H0:=H0) y).
+  exact (@cate_binprod_swap A^op _ _ _ _ _ hbc _ _).
 Defined.
 
-Global Instance is0functor_cat_coprod_r {A : Type}
-  `{H0 : HasBinaryCoproducts A} x
-  : Is0Functor (fun y => cat_coprod x y).
+(** *** Associativity of coproducts *)
+
+Lemma cate_coprod_assoc {A : Type} `{HasEquivs A}
+  {hbc : HasBinaryCoproducts A} (x y z : A)
+  : cat_bincoprod x (cat_bincoprod y z)
+    $<~> cat_bincoprod (cat_bincoprod x y) z.
 Proof.
-  rapply is0functor_op'.
-  exact (is0functor_cat_prod_r (A:=A^op) (H0:=H0) x).
+  exact (@associator_cat_binprod A^op _ _ _ _ _ hbc x y z)^-1$.
 Defined.
 
-Global Instance is1functor_cat_coprod_r {A : Type}
-  `{H0 : HasBinaryCoproducts A} x
-  : Is1Functor (fun y => cat_coprod x y).
+Definition associator_cat_bincoprod {A : Type} `{HasEquivs A}
+  `{!HasBinaryCoproducts A}
+  : Associator (fun x y => cat_bincoprod x y).
 Proof.
-  rapply is1functor_op'.
-  exact (is1functor_cat_prod_r (A:=A^op) (H0:=H0) x).
+  unfold Associator.
+  snrapply associator_op'.
+  1: exact _.
+  nrapply associator_cat_binprod.
+Defined.
+
+(** *** Codiagonal *)
+
+Definition cat_bincoprod_codiag {A : Type}
+  `{Is1Cat A} (x : A) `{!BinaryCoproduct x x}
+  : cat_bincoprod x x $-> x
+  := cat_binprod_diag (A:=A^op) x.
+
+(** *** Lemmas about [cat_bincoprod_rec] *)
+
+Definition cat_bincoprod_fmap01_rec {A : Type}
+  `{Is1Cat A, !HasBinaryCoproducts A} {w x y z : A}
+  (f : z $-> w) (g : y $-> x) (h : x $-> w)
+  : cat_bincoprod_rec f h $o fmap01 (fun x y => cat_bincoprod x y) z g
+    $== cat_bincoprod_rec f (h $o g)
+  := @cat_binprod_fmap01_corec A^op _ _ _ _
+      hasbinaryproducts_op_hasbinarycoproducts _ _ _ _ f g h.
+
+Definition cat_bincoprod_fmap10_rec {A : Type}
+  `{Is1Cat A, !HasBinaryCoproducts A} {w x y z : A}
+  (f : y $-> x) (g : x $-> w) (h : z $-> w) 
+  : cat_bincoprod_rec g h $o fmap10 (fun x y => cat_bincoprod x y) f z
+    $== cat_bincoprod_rec (g $o f) h
+  := @cat_binprod_fmap10_corec A^op _ _ _ _
+      hasbinaryproducts_op_hasbinarycoproducts _ _ _ _ f g h.
+
+Definition cat_bincoprod_fmap11_rec {A : Type}
+  `{Is1Cat A, !HasBinaryCoproducts A} {v w x y z : A}
+  (f : y $-> w) (g : z $-> x) (h : w $-> v) (i : x $-> v)
+  : cat_bincoprod_rec h i $o fmap11 (fun x y => cat_binprod x y) f g
+    $== cat_bincoprod_rec (h $o f) (i $o g)
+  := @cat_binprod_fmap11_corec A^op _ _ _ _
+      hasbinaryproducts_op_hasbinarycoproducts _ _ _ _ _ f g h i.
+
+Definition cat_bincoprod_rec_associator {A : Type} `{HasEquivs A}
+  {hbc : HasBinaryCoproducts A}
+  {w x y z : A} (f : w $-> z) (g : x $-> z) (h : y $-> z)
+  : cat_bincoprod_rec (cat_bincoprod_rec f g) h $o associator_cat_bincoprod w x y
+    $== cat_bincoprod_rec f (cat_bincoprod_rec g h).
+Proof.
+  nrapply cate_moveR_eV.
+  symmetry.
+  exact (cat_binprod_associator_corec
+           (HasBinaryProducts0:=hasbinaryproducts_op_hasbinarycoproducts (hbc:=hbc))
+           f g h).
+Defined.
+
+Definition cat_bincoprod_swap_rec {A : Type} `{Is1Cat A}
+  `{!HasBinaryCoproducts A} {a b c : A} (f : a $-> c) (g : b $-> c)
+  : cat_bincoprod_rec f g $o cat_bincoprod_swap b a $== cat_bincoprod_rec g f
+  := @cat_binprod_swap_corec A^op _ _ _ _
+      hasbinaryproducts_op_hasbinarycoproducts _ _ _ _ _.
+
+(** *** Cocartesian Monoidal Structure *)
+
+Global Instance ismonoidal_cat_bincoprod {A : Type} `{HasEquivs A}
+  `{!HasBinaryCoproducts A} (zero : A) `{!IsInitial zero}
+  : IsMonoidal A (fun x y => cat_bincoprod x y) zero.
+Proof.
+  nrapply ismonoidal_op'.
+  nrapply (ismonoidal_cat_binprod (A:=A^op) zero).
+  by nrapply isterminal_op_isinitial.
+Defined.
+
+Global Instance issymmetricmonoidal_cat_bincoprod {A : Type} `{HasEquivs A}
+  `{!HasBinaryCoproducts A} (zero : A) `{!IsInitial zero}
+  : IsSymmetricMonoidal A (fun x y => cat_bincoprod x y) zero.
+Proof.
+  nrapply issymmetricmonoidal_op'.
+  nrapply (issymmetricmonoidal_cat_binprod (A:=A^op) zero).
+  by nrapply isterminal_op_isinitial.
 Defined.
 
 (** *** Coproducts in Type *)
 
-(** [Type] has all binary coproducts *)
-Global Instance hasbinarycoproducts_type : HasBinaryCoproducts Type.
-Proof.
-  intros X Y.
-  snrapply Build_BinaryCoproduct.
-  - exact (X + Y).
-  - exact inl.
-  - exact inr.
-  - intros Z f g.
-    intros [x | y].
-    + exact (f x).
-    + exact (g y).
-  - reflexivity.
-  - reflexivity.
-  - intros Z f g p q [x | y].
-    + exact (p x).
-    + exact (q y).
+(** [Type] has all coproducts. *)
+Global Instance hasallcoproducts_type : HasAllCoproducts Type.
+Proof.
+  intros I x.
+  snrapply Build_Coproduct.
+  - exact (sig (fun i : I => x i)).
+  - exact (exist x).
+  - intros A f [i xi].
+    exact (f i xi).
+  - intros A f i xi; reflexivity.
+  - intros A f g p [i xi].
+    exact (p i xi).
+Defined.
+
+(** In particular, [Type] has all binary coproducts. *)
+Global Instance hasbinarycoproducts_type : HasBinaryCoproducts Type
+  := {}.
+
+(** ** Canonical coproduct-product map *)
+
+(** There is a canonical map from a coproduct to a product when the indexing set has decidable equality and the category is pointed. *)
+Definition cat_coprod_prod {I : Type} `{DecidablePaths I} {A : Type}
+  `{Is1Cat A, !IsPointedCat A}
+  (x : I -> A) `{!Coproduct I x, !Product I x}
+  : cat_coprod I x $-> cat_prod I x. 
+Proof.
+  apply cat_coprod_rec.
+  intros i.
+  apply cat_prod_corec.
+  intros a.
+  destruct (dec_paths i a) as [p|].
+  - destruct p.
+    exact (Id _).
+  - apply zero_morphism. 
 Defined.
+
+Definition cat_bincoprod_binprod {A : Type} `{Is1Cat A, !IsPointedCat A}
+  (x y : A) `{!BinaryCoproduct x y, !BinaryProduct x y}
+  : cat_bincoprod x y $-> cat_binprod x y.
+Proof.
+  nrapply cat_coprod_prod; exact _.
+Defined.
+
+(** *** Coproducts in the opposite category *)
+
+Definition coproduct_op {I A : Type} (x : I -> A)
+  `{Is1Cat A} {H' : Product I x}
+  : Coproduct I (A:=A^op) x
+  := H'.
+  
+Hint Immediate coproduct_op : typeclass_instances.
diff --git a/theories/WildCat/Core.v b/theories/WildCat/Core.v
index 08c25f159f0..bf917a67d9c 100644
--- a/theories/WildCat/Core.v
+++ b/theories/WildCat/Core.v
@@ -74,12 +74,14 @@ Global Instance symmetric_GpdHom' {A} `{Is0Gpd A}
   : Symmetric Hom
   := fun a b f => f^$.
 
-Definition GpdHom_path {A} `{Is0Gpd A} {a b : A} (p : a = b)
-  : a $== b.
+Definition Hom_path {A : Type} `{Is01Cat A} {a b : A} (p : a = b) : (a $-> b).
 Proof.
   destruct p; apply Id.
 Defined.
 
+Definition GpdHom_path {A} `{Is0Gpd A} {a b : A} (p : a = b) : a $== b
+  := Hom_path p.
+
 (** A 0-functor acts on morphisms, but satisfies no axioms. *)
 Class Is0Functor {A B : Type} `{IsGraph A} `{IsGraph B} (F : A -> B)
   := { fmap : forall (a b : A) (f : a $-> b), F a $-> F b }.
@@ -100,6 +102,8 @@ Class Is1Cat (A : Type) `{!IsGraph A, !Is2Graph A, !Is01Cat A} :=
   is0functor_precomp : forall (a b c : A) (f : a $-> b), Is0Functor (cat_precomp c f) ;
   cat_assoc : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d),
     (h $o g) $o f $== h $o (g $o f);
+  cat_assoc_opp : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d),
+    h $o (g $o f) $== (h $o g) $o f;
   cat_idl : forall (a b : A) (f : a $-> b), Id b $o f $== f;
   cat_idr : forall (a b : A) (f : a $-> b), f $o Id a $== f;
 }.
@@ -109,13 +113,23 @@ Global Existing Instance is0gpd_hom.
 Global Existing Instance is0functor_postcomp.
 Global Existing Instance is0functor_precomp.
 Arguments cat_assoc {_ _ _ _ _ _ _ _ _} f g h.
+Arguments cat_assoc_opp {_ _ _ _ _ _ _ _ _} f g h.
 Arguments cat_idl {_ _ _ _ _ _ _} f.
 Arguments cat_idr {_ _ _ _ _ _ _} f.
 
-Definition cat_assoc_opp {A : Type} `{Is1Cat A}
-           {a b c d : A} (f : a $-> b) (g : b $-> c) (h : c $-> d)
-  : h $o (g $o f) $== (h $o g) $o f
-  := (cat_assoc f g h)^$.
+(** An alternate constructor that doesn't require the proof of [cat_assoc_opp].  This can be used for defining examples of wild categories, but shouldn't be used for the general theory of wild categories. *)
+Definition Build_Is1Cat' (A : Type) `{!IsGraph A, !Is2Graph A, !Is01Cat A}
+  (is01cat_hom : forall a b : A, Is01Cat (a $-> b))
+  (is0gpd_hom : forall a b : A, Is0Gpd (a $-> b))
+  (is0functor_postcomp : forall (a b c : A) (g : b $-> c), Is0Functor (cat_postcomp a g))
+  (is0functor_precomp : forall (a b c : A) (f : a $-> b), Is0Functor (cat_precomp c f))
+  (cat_assoc : forall (a b c d : A) (f : a $-> b) (g : b $-> c) (h : c $-> d),
+      h $o g $o f $== h $o (g $o f))
+  (cat_idl : forall (a b : A) (f : a $-> b), Id b $o f $== f)
+  (cat_idr : forall (a b : A) (f : a $-> b), f $o Id a $== f)
+  : Is1Cat A
+  := Build_Is1Cat A _ _ _ is01cat_hom is0gpd_hom is0functor_postcomp is0functor_precomp
+      cat_assoc (fun a b c d f g h => (cat_assoc a b c d f g h)^$) cat_idl cat_idr.
 
 (** Whiskering and horizontal composition of 2-cells. *)
 
@@ -162,7 +176,7 @@ Record RetractionOf {A} `{Is1Cat A} {a b : A} (f : a $-> b) :=
   }.
 
 (** Often, the coherences are actually equalities rather than homotopies. *)
-Class Is1Cat_Strong (A : Type)`{!IsGraph A, !Is2Graph A, !Is01Cat A} := 
+Class Is1Cat_Strong (A : Type)`{!IsGraph A, !Is2Graph A, !Is01Cat A} :=
 {
   is01cat_hom_strong : forall (a b : A), Is01Cat (a $-> b) ;
   is0gpd_hom_strong : forall (a b : A), Is0Gpd (a $-> b) ;
@@ -173,19 +187,18 @@ Class Is1Cat_Strong (A : Type)`{!IsGraph A, !Is2Graph A, !Is01Cat A} :=
   cat_assoc_strong : forall (a b c d : A)
     (f : a $-> b) (g : b $-> c) (h : c $-> d),
     (h $o g) $o f = h $o (g $o f) ;
+  cat_assoc_opp_strong : forall (a b c d : A)
+    (f : a $-> b) (g : b $-> c) (h : c $-> d),
+    h $o (g $o f) = (h $o g) $o f ;
   cat_idl_strong : forall (a b : A) (f : a $-> b), Id b $o f = f ;
   cat_idr_strong : forall (a b : A) (f : a $-> b), f $o Id a = f ;
 }.
 
 Arguments cat_assoc_strong {_ _ _ _ _ _ _ _ _} f g h.
+Arguments cat_assoc_opp_strong {_ _ _ _ _ _ _ _ _} f g h.
 Arguments cat_idl_strong {_ _ _ _ _ _ _} f.
 Arguments cat_idr_strong {_ _ _ _ _ _ _} f.
 
-Definition cat_assoc_opp_strong {A : Type} `{Is1Cat_Strong A}
-           {a b c d : A} (f : a $-> b) (g : b $-> c) (h : c $-> d)
-  : h $o (g $o f) = (h $o g) $o f
-  := (cat_assoc_strong f g h)^.
-
 Global Instance is1cat_is1cat_strong (A : Type) `{Is1Cat_Strong A}
   : Is1Cat A | 1000.
 Proof.
@@ -196,6 +209,7 @@ Proof.
   - apply is0functor_postcomp_strong.
   - apply is0functor_precomp_strong.
   - intros; apply GpdHom_path, cat_assoc_strong.
+  - intros; apply GpdHom_path, cat_assoc_opp_strong.
   - intros; apply GpdHom_path, cat_idl_strong.
   - intros; apply GpdHom_path, cat_idr_strong.
 Defined.
@@ -245,6 +259,7 @@ Global Instance is1cat_strong_hasmorext {A : Type} `{HasMorExt A}
 Proof.
   rapply Build_Is1Cat_Strong; hnf; intros; apply path_hom.
   + apply cat_assoc.
+  + apply cat_assoc_opp.
   + apply cat_idl.
   + apply cat_idr.
 Defined.
@@ -329,7 +344,7 @@ End ConstantFunctor.
 
 Global Instance is0functor_compose {A B C : Type}
   `{IsGraph A, IsGraph B, IsGraph C}
-  (F : A -> B) (G : B -> C) `{!Is0Functor F, !Is0Functor G}
+  (F : A -> B) `{!Is0Functor F} (G : B -> C) `{!Is0Functor G}
   : Is0Functor (G o F).
 Proof.
   srapply Build_Is0Functor.
@@ -365,26 +380,26 @@ Arguments is1functor_compose {A B C}
 (** ** Wild 1-groupoids *)
 
 Class Is1Gpd (A : Type) `{Is1Cat A, !Is0Gpd A} :=
-{ 
+{
   gpd_issect : forall {a b : A} (f : a $-> b), f^$ $o f $== Id a ;
   gpd_isretr : forall {a b : A} (f : a $-> b), f $o f^$ $== Id b ;
 }.
 
 (** Some more convenient equalities for morphisms in a 1-groupoid. The naming scheme is similar to [PathGroupoids.v].*)
 
-Definition gpd_V_hh {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b) 
+Definition gpd_V_hh {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b)
   : f^$ $o (f $o g) $== g :=
   (cat_assoc _ _ _)^$ $@ (gpd_issect f $@R g) $@ cat_idl g.
 
-Definition gpd_h_Vh {A} `{Is1Gpd A} {a b c : A} (f : c $-> b) (g : a $-> b) 
+Definition gpd_h_Vh {A} `{Is1Gpd A} {a b c : A} (f : c $-> b) (g : a $-> b)
   : f $o (f^$ $o g) $== g :=
   (cat_assoc _ _ _)^$ $@ (gpd_isretr f $@R g) $@ cat_idl g.
 
-Definition gpd_hh_V {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b) 
+Definition gpd_hh_V {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b)
   : (f $o g) $o g^$ $== f :=
   cat_assoc _ _ _ $@ (f $@L gpd_isretr g) $@ cat_idr f.
 
-Definition gpd_hV_h {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : b $-> a) 
+Definition gpd_hV_h {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : b $-> a)
   : (f $o g^$) $o g $== f :=
   cat_assoc _ _ _ $@ (f $@L gpd_issect g) $@ cat_idr f.
 
@@ -426,13 +441,13 @@ Proof.
 Defined.
 
 Definition gpd_moveR_hV {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
-  {q : x $-> y} {r : x $-> z} (s : r $== p $o q) 
-  : r $o q^$ $== p 
+  {q : x $-> y} {r : x $-> z} (s : r $== p $o q)
+  : r $o q^$ $== p
   := (s $@R q^$) $@ gpd_hh_V _ _.
 
 Definition gpd_moveR_Vh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
-  {q : x $-> y} {r : x $-> z} (s : r $== p $o q) 
-  : p^$ $o r $== q 
+  {q : x $-> y} {r : x $-> z} (s : r $== p $o q)
+  : p^$ $o r $== q
   := (p^$ $@L s) $@ gpd_V_hh _ _.
 
 Definition gpd_moveL_hM {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
@@ -440,8 +455,8 @@ Definition gpd_moveL_hM {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
   : r $== p $o q := ((gpd_hV_h _ _)^$ $@ (s $@R _)).
 
 Definition gpd_moveL_hV {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
-  {q : x $-> y} {r : x $-> z} (s : p $o q $== r) 
-  : p $== r $o q^$ 
+  {q : x $-> y} {r : x $-> z} (s : p $o q $== r)
+  : p $== r $o q^$
   := (gpd_moveR_hV s^$)^$.
 
 Definition gpd_moveL_Mh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
@@ -449,8 +464,8 @@ Definition gpd_moveL_Mh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
   : r $== p $o q := ((gpd_h_Vh _ _)^$ $@ (p $@L s)).
 
 Definition gpd_moveL_Vh {A : Type} `{Is1Gpd A} {x y z : A} {p : y $-> z}
-  {q : x $-> y} {r : x $-> z} (s : p $o q $== r) 
-  : q $== p^$ $o r 
+  {q : x $-> y} {r : x $-> z} (s : p $o q $== r)
+  : q $== p^$ $o r
   := (gpd_moveR_Vh s^$)^$.
 
 Definition gpd_rev2 {A : Type} `{Is1Gpd A} {x y : A} {p q : x $-> y}
@@ -461,7 +476,7 @@ Proof.
   exact (cat_idl q $@ r^$).
 Defined.
 
-Definition gpd_rev_pp {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b) 
+Definition gpd_rev_pp {A} `{Is1Gpd A} {a b c : A} (f : b $-> c) (g : a $-> b)
   : (f $o g)^$ $== g^$ $o f^$.
 Proof.
   apply gpd_moveR_V1.
@@ -579,9 +594,9 @@ Record BasepointPreservingFunctor (B C : Type)
     bp_pointed : bp_map (point B) $-> point C
   }.
 
-Arguments bp_pointed {B C}%type_scope {H H0 H1 H2 H3 H4} b.
-Arguments Build_BasepointPreservingFunctor {B C}%type_scope {H H0 H1 H2 H3 H4}
-  bp_map%function_scope {bp_is0functor} bp_pointed.
+Arguments bp_pointed {B C}%_type_scope {H H0 H1 H2 H3 H4} b.
+Arguments Build_BasepointPreservingFunctor {B C}%_type_scope {H H0 H1 H2 H3 H4}
+  bp_map%_function_scope {bp_is0functor} bp_pointed.
 
 Coercion bp_map : BasepointPreservingFunctor >-> Funclass.
 
diff --git a/theories/WildCat/Displayed.v b/theories/WildCat/Displayed.v
index 23cfce96553..4f04addf00d 100644
--- a/theories/WildCat/Displayed.v
+++ b/theories/WildCat/Displayed.v
@@ -47,14 +47,18 @@ Definition dgpd_comp {A : Type} {D : A -> Type} `{IsD0Gpd A D} {a b c : A}
 
 Notation "p '$@'' q" := (dgpd_comp p q).
 
-Definition DGpdHom_path {A : Type} {D : A -> Type} `{IsD0Gpd A D} {a b : A}
+Definition DHom_path {A : Type} {D : A -> Type} `{IsD01Cat A D} {a b : A}
   (p : a = b) {a' : D a} {b': D b} (p' : transport D p a' = b')
-  : DGpdHom (GpdHom_path p) a' b'.
+  : DHom (Hom_path p) a' b'.
 Proof.
-  destruct p, p'.
-  apply DId.
+  destruct p, p'; apply DId.
 Defined.
 
+Definition DGpdHom_path {A : Type} {D : A -> Type} `{IsD0Gpd A D} {a b : A}
+  (p : a = b) {a' : D a} {b': D b} (p' : transport D p a' = b')
+  : DGpdHom (GpdHom_path p) a' b'
+  := DHom_path p p'.
+
 Global Instance reflexive_DHom {A} {D : A -> Type} `{IsD01Cat A D} {a : A}
   : Reflexive (DHom (Id a))
   := fun a' => DId a'.
@@ -102,6 +106,11 @@ Class IsD1Cat {A : Type} `{Is1Cat A}
                (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d'),
                DHom (cat_assoc f g h) ((h' $o' g') $o' f')
                (h' $o' (g' $o' f'));
+  dcat_assoc_opp : forall {a b c d : A} {f : a $-> b} {g : b $-> c} {h : c $-> d}
+               {a' : D a} {b' : D b} {c' : D c} {d' : D d}
+               (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d'),
+               DHom (cat_assoc_opp f g h) (h' $o' (g' $o' f'))
+               ((h' $o' g') $o' f');
   dcat_idl : forall {a b : A} {f : a $-> b} {a' : D a} {b' : D b}
              (f' : DHom f a' b'), DHom (cat_idl f) (DId b' $o' f') f';
   dcat_idr : forall {a b : A} {f : a $-> b} {a' : D a} {b' : D b}
@@ -113,13 +122,6 @@ Global Existing Instance isd0gpd_hom.
 Global Existing Instance isd0functor_postcomp.
 Global Existing Instance isd0functor_precomp.
 
-Definition dcat_assoc_opp {A : Type} {D : A -> Type} `{IsD1Cat A D}
-  {a b c d : A}  {f : a $-> b} {g : b $-> c} {h : c $-> d}
-  {a' : D a} {b' : D b} {c' : D c} {d' : D d}
-  (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d')
-  : DHom (cat_assoc_opp f g h) (h' $o' (g' $o' f')) ((h' $o' g') $o' f')
-  := (dcat_assoc f' g' h')^$'.
-
 Definition dcat_postwhisker {A : Type} {D : A -> Type} `{IsD1Cat A D}
   {a b c : A} {f g : a $-> b} {h : b $-> c} {p : f $== g}
   {a' : D a} {b' : D b} {c' : D c} {f' : DHom f a' b'} {g' : DHom g a' b'}
@@ -162,7 +164,7 @@ Definition DEpic {A} {D : A -> Type} `{IsD1Cat A D} {a b : A}
       (g' : DHom g b' c') (h' : DHom h b' c'),
       DGpdHom p (g' $o' f') (h' $o' f') -> DGpdHom (epi c g h p) g' h'.
 
-Global Instance isgraph_sigma {A : Type} (D : A -> Type) `{IsDGraph A D}
+Global Instance isgraph_total {A : Type} (D : A -> Type) `{IsDGraph A D}
   : IsGraph (sig D).
 Proof.
   srapply Build_IsGraph.
@@ -170,7 +172,7 @@ Proof.
   exact {f : a $-> b & DHom f a' b'}.
 Defined.
 
-Global Instance is01cat_sigma {A : Type} (D : A -> Type) `{IsD01Cat A D}
+Global Instance is01cat_total {A : Type} (D : A -> Type) `{IsD01Cat A D}
   : Is01Cat (sig D).
 Proof.
   srapply Build_Is01Cat.
@@ -180,7 +182,7 @@ Proof.
     exact (g $o f; g' $o' f').
 Defined.
 
-Global Instance is0gpd_sigma {A : Type} (D : A -> Type) `{IsD0Gpd A D}
+Global Instance is0gpd_total {A : Type} (D : A -> Type) `{IsD0Gpd A D}
   : Is0Gpd (sig D).
 Proof.
   srapply Build_Is0Gpd.
@@ -188,7 +190,7 @@ Proof.
   exact (f^$; dgpd_rev f').
 Defined.
 
-Global Instance is0functor_pr1 {A : Type} (D : A -> Type) `{IsDGraph A D}
+Global Instance is0functor_total_pr1 {A : Type} (D : A -> Type) `{IsDGraph A D}
   : Is0Functor (pr1 : sig D -> A).
 Proof.
   srapply Build_Is0Functor.
@@ -196,7 +198,7 @@ Proof.
   exact f.
 Defined.
 
-Global Instance is2graph_sigma {A : Type} (D : A -> Type) `{IsD2Graph A D}
+Global Instance is2graph_total {A : Type} (D : A -> Type) `{IsD2Graph A D}
   : Is2Graph (sig D).
 Proof.
   intros [a a'] [b b'].
@@ -205,7 +207,7 @@ Proof.
   exact ({p : f $-> g & DHom p f' g'}).
 Defined.
 
-Global Instance is0functor_sigma {A : Type} (DA : A -> Type) `{IsD01Cat A DA}
+Global Instance is0functor_total {A : Type} (DA : A -> Type) `{IsD01Cat A DA}
   {B : Type} (DB : B -> Type) `{IsD01Cat B DB} (F : A -> B) `{!Is0Functor F}
   (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F'}
   : Is0Functor (functor_sigma F F').
@@ -216,7 +218,7 @@ Proof.
   exact (fmap F f; dfmap F F' f').
 Defined.
 
-Global Instance is1cat_sigma {A : Type} (D : A -> Type) `{IsD1Cat A D}
+Global Instance is1cat_total {A : Type} (D : A -> Type) `{IsD1Cat A D}
   : Is1Cat (sig D).
 Proof.
   srapply Build_Is1Cat.
@@ -230,6 +232,8 @@ Proof.
     exact (p $@R f; p' $@R' f').
   - intros [a a'] [b b'] [c c'] [d d'] [f f'] [g g'] [h h'].
     exact (cat_assoc f g h; dcat_assoc f' g' h').
+  - intros [a a'] [b b'] [c c'] [d d'] [f f'] [g g'] [h h'].
+    exact (cat_assoc_opp f g h; dcat_assoc_opp f' g' h').
   - intros [a a'] [b b'] [f f'].
     exact (cat_idl f; dcat_idl f').
   - intros [a a'] [b b'] [f f'].
@@ -271,6 +275,11 @@ Class IsD1Cat_Strong {A : Type} `{Is1Cat_Strong A}
                       (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d'),
                       (transport (fun k => DHom k a' d') (cat_assoc_strong f g h)
                       ((h' $o' g') $o' f')) = h' $o' (g' $o' f');
+  dcat_assoc_opp_strong : forall {a b c d : A} {f : a $-> b} {g : b $-> c} {h : c $-> d}
+                      {a' : D a} {b' : D b} {c' : D c} {d' : D d}
+                      (f' : DHom f a' b') (g' : DHom g b' c') (h' : DHom h c' d'),
+                      (transport (fun k => DHom k a' d') (cat_assoc_opp_strong f g h)
+                      (h' $o' (g' $o' f'))) = (h' $o' g') $o' f';
   dcat_idl_strong : forall {a b : A} {f : a $-> b} {a' : D a} {b' : D b}
                     (f' : DHom f a' b'),
                     (transport (fun k => DHom k a' b') (cat_idl_strong f)
@@ -286,6 +295,7 @@ Global Existing Instance isd0gpd_hom_strong.
 Global Existing Instance isd0functor_postcomp_strong.
 Global Existing Instance isd0functor_precomp_strong.
 
+(* If in the future we make a [Build_Is1Cat_Strong'] that lets the user omit the second proof of associativity, this shows how it can be recovered from the original proof:
 Definition dcat_assoc_opp_strong {A : Type} {D : A -> Type} `{IsD1Cat_Strong A D}
   {a b c d : A}  {f : a $-> b} {g : b $-> c} {h : c $-> d}
   {a' : D a} {b' : D b} {c' : D c} {d' : D d}
@@ -296,20 +306,23 @@ Proof.
   apply (moveR_transport_V (fun k => DHom k a' d') (cat_assoc_strong f g h) _ _).
   exact ((dcat_assoc_strong f' g' h')^).
 Defined.
+*)
 
 Global Instance isd1cat_isd1catstrong {A : Type} (D : A -> Type)
   `{IsD1Cat_Strong A D} : IsD1Cat D.
 Proof.
   srapply Build_IsD1Cat.
   - intros a b c d f g h a' b' c' d' f' g' h'.
-    exact (DGpdHom_path (cat_assoc_strong f g h) (dcat_assoc_strong f' g' h')).
+    exact (DHom_path (cat_assoc_strong f g h) (dcat_assoc_strong f' g' h')).
+  - intros a b c d f g h a' b' c' d' f' g' h'.
+    exact (DHom_path (cat_assoc_opp_strong f g h) (dcat_assoc_opp_strong f' g' h')).
   - intros a b f a' b' f'.
-    exact (DGpdHom_path (cat_idl_strong f) (dcat_idl_strong f')).
+    exact (DHom_path (cat_idl_strong f) (dcat_idl_strong f')).
   - intros a b f a' b' f'.
-    exact (DGpdHom_path (cat_idr_strong f) (dcat_idr_strong f')).
+    exact (DHom_path (cat_idr_strong f) (dcat_idr_strong f')).
 Defined.
 
-Global Instance is1catstrong_sigma {A : Type}
+Global Instance is1catstrong_total {A : Type}
   (D : A -> Type) `{IsD1Cat_Strong A D}
   : Is1Cat_Strong (sig D).
 Proof.
@@ -317,6 +330,9 @@ Proof.
   - intros aa' bb' cc' dd' [f f'] [g g'] [h h'].
     exact (path_sigma' _
             (cat_assoc_strong f g h) (dcat_assoc_strong f' g' h')).
+  - intros aa' bb' cc' dd' [f f'] [g g'] [h h'].
+    exact (path_sigma' _
+            (cat_assoc_opp_strong f g h) (dcat_assoc_opp_strong f' g' h')).
   - intros aa' bb' [f f'].
     exact (path_sigma' _ (cat_idl_strong f) (dcat_idl_strong f')).
   - intros aa' bb' [f f'].
@@ -346,7 +362,7 @@ Arguments dfmap_id {A B DA _ _ _ _ _ _ _ _ DB _ _ _ _ _ _ _ _}
 Arguments dfmap_comp {A B DA _ _ _ _ _ _ _ _ DB _ _ _ _ _ _ _ _}
   F {_ _} F' {_ _ a b c f g a' b' c'} f' g'.
 
-Global Instance is1functor_sigma {A B : Type} (DA : A -> Type) (DB : B -> Type)
+Global Instance is1functor_total {A B : Type} (DA : A -> Type) (DB : B -> Type)
   (F : A -> B) (F' : forall (a : A), DA a -> DB (F a)) `{IsD1Functor A B DA DB F F'}
   : Is1Functor (functor_sigma F F').
 Proof.
@@ -502,6 +518,9 @@ Proof.
   - intros ab1 ab2 ab3 ab4 fg1 fg2 fg3.
     intros ab1' ab2' ab3' ab4' [f1' g1'] [f2' g2'] [f3' g3'].
     exact (dcat_assoc f1' f2' f3', dcat_assoc g1' g2' g3').
+  - intros ab1 ab2 ab3 ab4 fg1 fg2 fg3.
+    intros ab1' ab2' ab3' ab4' [f1' g1'] [f2' g2'] [f3' g3'].
+    exact (dcat_assoc_opp f1' f2' f3', dcat_assoc_opp g1' g2' g3').
   - intros ab1 ab2 fg ab1' ab2' [f' g'].
     exact (dcat_idl f', dcat_idl g').
   - intros ab1 ab2 fg ab1' ab2' [f' g'].
diff --git a/theories/WildCat/DisplayedEquiv.v b/theories/WildCat/DisplayedEquiv.v
index 3a207682f58..6c2e5f921ac 100644
--- a/theories/WildCat/DisplayedEquiv.v
+++ b/theories/WildCat/DisplayedEquiv.v
@@ -136,7 +136,7 @@ Proof.
 Defined.
 
 (** If the base category has equivalences and the displayed category has displayed equivalences, then the total category has equivalences. *)
-Global Instance hasequivs_sigma {A} (D : A -> Type) `{DHasEquivs A D}
+Global Instance hasequivs_total {A} (D : A -> Type) `{DHasEquivs A D}
   : HasEquivs (sig D).
 Proof.
   snrapply Build_HasEquivs.
@@ -160,7 +160,7 @@ Defined.
 Global Instance dcatie_id {A} {D : A -> Type} `{DHasEquivs A D}
   {a : A} (a' : D a)
   : DCatIsEquiv (DId a')
-  := dcatie_adjointify (DId a') (DId a') (dcat_idl (DId a')) (dcat_idl (DId a')).
+  := dcatie_adjointify (DId a') (DId a') (dcat_idl (DId a')) (dcat_idr (DId a')).
 
 Definition did_cate {A} {D : A -> Type} `{DHasEquivs A D}
   {a : A} (a' : D a)
@@ -171,6 +171,27 @@ Global Instance reflexive_dcate {A} {D : A -> Type} `{DHasEquivs A D} {a : A}
   : Reflexive (DCatEquiv (id_cate a))
   := did_cate.
 
+(** Anything homotopic to an equivalence is an equivalence. This should not be an instance. *)
+Definition dcatie_homotopic {A} {D : A -> Type} `{DHasEquivs A D} {a b : A}
+  {f : a $-> b} `{!CatIsEquiv f} {g : a $-> b} {p : f $== g} {a' : D a}
+  {b' : D b} (f' : DHom f a' b') `{fe' : !DCatIsEquiv f'} {g' : DHom g a' b'}
+  (p' : DGpdHom p f' g')
+  : DCatIsEquiv (fe:=catie_homotopic f p) g'.
+Proof.
+  snrapply dcatie_adjointify.
+  - exact (Build_DCatEquiv (fe':=fe') f')^-1$'.
+  - refine (p'^$' $@R' _ $@' _).
+    1: exact isd0gpd_hom.
+    refine ((dcate_buildequiv_fun f')^$' $@R' _ $@' _).
+    1: exact isd0gpd_hom.
+    apply dcate_isretr.
+  - refine (_ $@L' p'^$' $@' _).
+    1: exact isd0gpd_hom.
+    refine (_ $@L' (dcate_buildequiv_fun f')^$' $@' _).
+    1: exact isd0gpd_hom.
+    apply dcate_issect.
+Defined.
+
 (** Equivalences can be composed. *)
 Global Instance dcompose_catie {A} {D : A -> Type} `{DHasEquivs A D}
   {a b c : A} {g : b $<~> c} {f : a $<~> b} {a' : D a} {b' : D b} {c' : D c}
@@ -184,13 +205,26 @@ Proof.
     refine (_ $@L' (dcate_isretr _ $@R' _) $@' _).
     refine (_ $@L' dcat_idl _ $@' _).
     apply dcate_isretr.
-  - refine (dcat_assoc _ _ _ $@' _).
-    refine (_ $@L' dcat_assoc_opp _ _ _ $@' _).
-    refine (_ $@L' (dcate_issect _ $@R' _) $@' _).
-    refine (_ $@L' dcat_idl _ $@' _).
+  - refine (dcat_assoc_opp _ _ _ $@' _).
+    refine (dcat_assoc _ _ _ $@R' _ $@' _).
+    refine (((_ $@L' dcate_issect _) $@R' _) $@' _).
+    refine ((dcat_idr _ $@R' _) $@' _).
     apply dcate_issect.
 Defined.
 
+Global Instance dcompose_catie' {A} {D : A -> Type} `{DHasEquivs A D}
+  {a b c : A} {g : b $-> c} `{!CatIsEquiv g} {f : a $-> b} `{!CatIsEquiv f}
+  {a' : D a} {b' : D b} {c' : D c}
+  (g' : DHom g b' c') `{ge' : !DCatIsEquiv g'}
+  (f' : DHom f a' b') `{fe' : !DCatIsEquiv f'}
+  : DCatIsEquiv (fe:=compose_catie' g f) (g' $o' f').
+Proof.
+  pose (ff:=Build_DCatEquiv (fe':=fe') f').
+  pose (gg:=Build_DCatEquiv (fe':=ge') g').
+  nrefine (dcatie_homotopic (fe':=dcompose_catie gg ff) _ _).
+  exact (dcate_buildequiv_fun _ $@@' dcate_buildequiv_fun _).
+Defined.
+
 Definition dcompose_cate {A} {D : A -> Type} `{DHasEquivs A D}
   {a b c : A} {g : b $<~> c} {f : a $<~> b} {a' : D a} {b' : D b} {c' : D c}
   (g' : DCatEquiv g b' c') (f' : DCatEquiv f a' b')
@@ -250,7 +284,7 @@ Definition dcompose_cate_idr {A} {D : A -> Type} `{DHasEquivs A D}
     (dcate_fun f').
 Proof.
   refine (dcompose_cate_fun f' _ $@' _ $@' dcat_idr (dcate_fun f')).
-  apply (_ $@L' dcate_buildequiv_fun _).
+  rapply (_ $@L' dcate_buildequiv_fun _).
 Defined.
 
 (** Some more convenient equalities for equivalences. The naming scheme is similar to [PathGroupoids.v].*)
@@ -259,13 +293,13 @@ Definition dcompose_V_hh {A} {D : A -> Type} `{DHasEquivs A D}
   {a b c : A} {f : b $<~> c} {g : a $-> b} {a' : D a} {b' : D b} {c' : D c}
   (f' : DCatEquiv f b' c') (g' : DHom g a' b')
   : DGpdHom (compose_V_hh f g) (dcate_fun f'^-1$' $o' (dcate_fun f' $o' g')) g'
-  := (dcat_assoc _ _ _)^$' $@' (dcate_issect f' $@R' g') $@' dcat_idl g'.
+  := (dcat_assoc_opp _ _ _) $@' (dcate_issect f' $@R' g') $@' dcat_idl g'.
 
 Definition dcompose_h_Vh {A} {D : A -> Type} `{DHasEquivs A D}
   {a b c : A} {f : c $<~> b} {g : a $-> b} {a' : D a} {b' : D b} {c' : D c}
   (f' : DCatEquiv f c' b') (g' : DHom g a' b')
   : DGpdHom (compose_h_Vh f g) (dcate_fun f' $o' (dcate_fun f'^-1$' $o' g')) g'
-  := (dcat_assoc _ _ _)^$' $@' (dcate_isretr f' $@R' g') $@' dcat_idl g'.
+  := (dcat_assoc_opp _ _ _) $@' (dcate_isretr f' $@R' g') $@' dcat_idl g'.
 
 Definition dcompose_hh_V {A} {D : A -> Type} `{DHasEquivs A D}
   {a b c : A} {f : b $-> c} {g : a $<~> b} {a' : D a} {b' : D b} {c' : D c}
@@ -304,24 +338,24 @@ Defined.
 (** Some lemmas for moving equivalences around.  Naming based on EquivGroupoids.v. *)
 
 Definition dcate_moveR_eM {A} {D : A -> Type} `{DHasEquivs A D}
-  {a b c : A} {e : b $<~> a} {f : b $<~> c} {g : a $<~> c}
-  {p : cate_fun g $== f $o e^-1$} {a' : D a} {b' : D b} {c' : D c}
-  (e' : DCatEquiv e b' a') (f' : DCatEquiv f b' c') (g' : DCatEquiv g a' c')
-  (p' : DGpdHom p (dcate_fun g') (dcate_fun f' $o' e'^-1$'))
-  : DGpdHom (cate_moveR_eM e f g p) (dcate_fun g' $o' e') (dcate_fun f').
+  {a b c : A} {e : b $<~> a} {f : a $-> c} {g : b $-> c}
+  {p : f $== g $o e^-1$} {a' : D a} {b' : D b} {c' : D c}
+  (e' : DCatEquiv e b' a') (f' : DHom f a' c') (g' : DHom g b' c')
+  (p' : DGpdHom p f' (g' $o' e'^-1$'))
+  : DGpdHom (cate_moveR_eM e f g p) (f' $o' e') g'.
 Proof.
   apply (dcate_epic_equiv e'^-1$').
   exact (dcompose_hh_V _ _ $@' p').
 Defined.
 
 Definition dcate_moveR_Ve {A} {D : A -> Type} `{DHasEquivs A D}
-  {a b c : A} {e : b $<~> a} {f : b $<~> c} {g : c $<~> a}
-  {p : cate_fun e $== g $o f} {a' : D a} {b' : D b} {c' : D c}
-  (e' : DCatEquiv e b' a') (f' : DCatEquiv f b' c') (g' : DCatEquiv g c' a')
-  (p' : DGpdHom p (dcate_fun e') (dcate_fun g' $o' f'))
-  : DGpdHom (cate_moveR_Ve e f g p) (dcate_fun g'^-1$' $o' e') (dcate_fun f').
+  {a b c : A} {e : b $<~> c} {f : a $-> c} {g : a $-> b}
+  {p : f $== e $o g} {a' : D a} {b' : D b} {c' : D c}
+  (e' : DCatEquiv e b' c') (f' : DHom f a' c') (g' : DHom g a' b')
+  (p' : DGpdHom p f' (dcate_fun e' $o' g'))
+  : DGpdHom (cate_moveR_Ve e f g p) (dcate_fun e'^-1$' $o' f') g'.
 Proof.
-  apply (dcate_monic_equiv g').
+  apply (dcate_monic_equiv e').
   exact (dcompose_h_Vh _ _ $@' p').
 Defined.
 
@@ -445,7 +479,7 @@ Defined.
 Definition demap_compose {A B : Type}
   {DA : A -> Type} `{DHasEquivs A DA} {DB : B -> Type} `{DHasEquivs B DB}
   (F : A -> B) `{!Is0Functor F, !Is1Functor F}
-  (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F', !IsD1Functor F F'}
+  (F' : forall (a : A), DA a -> DB (F a)) `{!IsD0Functor F F', isd1f : !IsD1Functor F F'}
   {a b c : A} {f : a $<~> b} {g : b $<~> c} {a' : DA a} {b' : DA b} {c' : DA c}
   (f' : DCatEquiv f a' b') (g' : DCatEquiv g b' c')
   : DGpdHom (emap_compose F f g) (dcate_fun (demap F F' (g' $oE' f')))
@@ -453,7 +487,7 @@ Definition demap_compose {A B : Type}
 Proof.
   refine (dcate_buildequiv_fun _ $@' _).
   refine (dfmap2 F F' (dcompose_cate_fun _ _) $@' _).
-  rapply dfmap_comp.
+  nrapply dfmap_comp; exact isd1f.
 Defined.
 
 (** A variant. *)
@@ -506,13 +540,13 @@ Definition dcat_path_equiv {A} {D : A -> Type} `{IsDUnivalent1Cat A D}
   := (dcat_equiv_path p a' b')^-1.
 
 (** If [IsUnivalent1Cat A] and [IsDUnivalent1Cat D], then this is an equivalence by [isequiv_functor_sigma]. *)
-Definition dcat_equiv_path_sigma {A} {D : A -> Type} `{DHasEquivs A D}
+Definition dcat_equiv_path_total {A} {D : A -> Type} `{DHasEquivs A D}
   {a b : A} (a' : D a) (b' : D b)
   : {p : a = b & p # a' = b'} -> {e : a $<~> b & DCatEquiv e a' b'}
   := functor_sigma (cat_equiv_path a b) (fun p => dcat_equiv_path p a' b').
 
 (** If the base category and the displayed category are both univalent, then the total category is univalent. *)
-Global Instance isunivalent1cat_sigma {A} `{IsUnivalent1Cat A} (D : A -> Type)
+Global Instance isunivalent1cat_total {A} `{IsUnivalent1Cat A} (D : A -> Type)
   `{!IsDGraph D, !IsD2Graph D, !IsD01Cat D, !IsD1Cat D, !DHasEquivs D}
   `{!IsDUnivalent1Cat D}
   : IsUnivalent1Cat (sig D).
@@ -520,6 +554,6 @@ Proof.
   snrapply Build_IsUnivalent1Cat.
   intros aa' bb'.
   apply (isequiv_homotopic
-          (dcat_equiv_path_sigma _ _ o (path_sigma_uncurried D aa' bb')^-1)).
+          (dcat_equiv_path_total _ _ o (path_sigma_uncurried D aa' bb')^-1)).
   intros []; reflexivity.
 Defined.
diff --git a/theories/WildCat/Equiv.v b/theories/WildCat/Equiv.v
index 820c839bc5a..240906b2966 100644
--- a/theories/WildCat/Equiv.v
+++ b/theories/WildCat/Equiv.v
@@ -1,7 +1,8 @@
 (* -*- mode: coq; mode: visual-line -*-  *)
 
-Require Import Basics.Utf8 Basics.Overture Basics.Tactics.
+Require Import Basics.Utf8 Basics.Overture Basics.Tactics Basics.Equivalences.
 Require Import WildCat.Core.
+Require Import WildCat.Opposite.
 
 (** We declare a scope for printing [CatEquiv] as [≅] *)
 Declare Scope wc_iso_scope.
@@ -85,7 +86,29 @@ Defined.
 
 Notation "f ^-1$" := (cate_inv f).
 
-Definition cate_issect {A} `{HasEquivs A} {a b} (f : a $<~> b) 
+(** * Opposite categories preserve having equivalences. *)
+Global Instance hasequivs_op {A} `{HasEquivs A} : HasEquivs A^op.
+Proof.
+  snrapply Build_HasEquivs; intros a b; unfold op in a, b; cbn.
+  - exact (b $<~> a).
+  - apply CatIsEquiv.
+  - apply cate_fun'.
+  - apply cate_isequiv'.
+  - apply cate_buildequiv'.
+  - rapply cate_buildequiv_fun'.
+  - apply cate_inv'.
+  - rapply cate_isretr'.
+  - rapply cate_issect'.
+  - intros f g s t.
+    exact (catie_adjointify f g t s).
+Defined.
+
+Global Instance isequiv_op {A : Type} `{HasEquivs A}
+       {a b : A} (f : a $-> b) {ief : CatIsEquiv f}
+  : @CatIsEquiv A^op _ _ _ _ _ b a f
+  := ief.
+
+Definition cate_issect {A} `{HasEquivs A} {a b} (f : a $<~> b)
   : f^-1$ $o f $== Id a.
 Proof.
   refine (_ $@ cate_issect' a b f).
@@ -94,12 +117,8 @@ Proof.
 Defined.
 
 Definition cate_isretr {A} `{HasEquivs A} {a b} (f : a $<~> b)
-  : f $o f^-1$ $== Id b.
-Proof.
-  refine (_ $@ cate_isretr' a b f).
-  refine (f $@L _).
-  apply cate_buildequiv_fun'.
-Defined.
+  : f $o f^-1$ $== Id b
+  := cate_issect (A:=A^op) (b:=a) (a:=b) f.
 
 (** If [g] is a section of an equivalence, then it is the inverse. *)
 Definition cate_inverse_sect {A} `{HasEquivs A} {a b} (f : a $<~> b)
@@ -116,14 +135,8 @@ Defined.
 (** If [g] is a retraction of an equivalence, then it is the inverse. *)
 Definition cate_inverse_retr {A} `{HasEquivs A} {a b} (f : a $<~> b)
   (g : b $-> a) (p : g $o f $== Id a)
-  : cate_fun f^-1$ $== g.
-Proof.
-  refine ((cat_idl _)^$ $@ _).
-  refine ((p^$ $@R _) $@ _).
-  refine (cat_assoc _ _ _ $@ _).
-  refine (_ $@L cate_isretr f $@ _).
-  apply cat_idr.
-Defined.
+  : cate_fun f^-1$ $== g
+  := cate_inverse_sect (A:=A^op) (a:=b) (b:=a) f g p.
 
 (** It follows that the inverse of the equivalence you get by adjointification is homotopic to the inverse [g] provided. *)
 Definition cate_inv_adjointify {A} `{HasEquivs A} {a b : A}
@@ -137,7 +150,7 @@ Defined.
 (** The identity morphism is an equivalence *)
 Global Instance catie_id {A} `{HasEquivs A} (a : A)
   : CatIsEquiv (Id a)
-  := catie_adjointify (Id a) (Id a) (cat_idl (Id a)) (cat_idl (Id a)).
+  := catie_adjointify (Id a) (Id a) (cat_idl (Id a)) (cat_idr (Id a)).
 
 Definition id_cate {A} `{HasEquivs A} (a : A)
   : a $<~> a
@@ -151,24 +164,53 @@ Global Instance symmetric_cate {A} `{HasEquivs A}
   : Symmetric (@CatEquiv A _ _ _ _ _)
   := fun a b f => cate_inv f.
 
-(** Equivalences can be composed. *)
+(** Anything homotopic to an equivalence is an equivalence. This should not be an instance. *)
+Definition catie_homotopic {A} `{HasEquivs A} {a b : A}
+  (f : a $-> b) `{!CatIsEquiv f} {g : a $-> b} (p : f $== g)
+  : CatIsEquiv g.
+Proof.
+  snrapply catie_adjointify.
+  - exact (Build_CatEquiv f)^-1$.
+  - refine (p^$ $@R _ $@ _).
+    refine ((cate_buildequiv_fun f)^$ $@R _ $@ _).
+    apply cate_isretr.
+  - refine (_ $@L p^$ $@ _).
+    refine (_ $@L (cate_buildequiv_fun f)^$ $@ _).
+    apply cate_issect.
+Defined.
+
+(** Equivalences can be composed.  In order to make use of duality, we factor out parts of the proof as two lemmas. *)
+
+Definition compose_catie_isretr {A} `{HasEquivs A} {a b c : A}
+  (g : b $<~> c) (f : a $<~> b)
+  : g $o f $o (f^-1$ $o g^-1$) $== Id c.
+Proof.
+  refine (cat_assoc _ _ _ $@ _).
+  refine ((_ $@L cat_assoc_opp _ _ _) $@ _).
+  refine ((_ $@L (cate_isretr _ $@R _)) $@ _).
+  refine ((_ $@L cat_idl _) $@ _).
+  apply cate_isretr.
+Defined.
+
+Definition compose_catie_issect {A} `{HasEquivs A} {a b c : A}
+  (g : b $<~> c) (f : a $<~> b)
+  : (f^-1$ $o g^-1$ $o (g $o f) $== Id a)
+  := compose_catie_isretr (A:=A^op) (a:=c) (b:=b) (c:=a) f g.
+
 Global Instance compose_catie {A} `{HasEquivs A} {a b c : A}
   (g : b $<~> c) (f : a $<~> b)
   : CatIsEquiv (g $o f).
 Proof.
   refine (catie_adjointify _ (f^-1$ $o g^-1$) _ _).
-  - refine (cat_assoc _ _ _ $@ _).
-    refine ((_ $@L cat_assoc_opp _ _ _) $@ _).
-    refine ((_ $@L (cate_isretr _ $@R _)) $@ _).
-    refine ((_ $@L cat_idl _) $@ _).
-    apply cate_isretr.
-  - refine (cat_assoc _ _ _ $@ _).
-    refine ((_ $@L cat_assoc_opp _ _ _) $@ _).
-    refine ((_ $@L (cate_issect _ $@R _)) $@ _).
-    refine ((_ $@L cat_idl _) $@ _).
-    apply cate_issect.
+  - apply compose_catie_isretr.
+  - apply compose_catie_issect.
 Defined.
 
+Global Instance compose_catie' {A} `{HasEquivs A} {a b c : A}
+  (g : b $-> c) `{!CatIsEquiv g} (f : a $-> b) `{!CatIsEquiv f}
+  : CatIsEquiv (g $o f)
+  := catie_homotopic _ (cate_buildequiv_fun _ $@@ cate_buildequiv_fun _).
+
 Definition compose_cate {A} `{HasEquivs A} {a b c : A}
   (g : b $<~> c) (f : a $<~> b) : a $<~> c
   := Build_CatEquiv (g $o f).
@@ -190,7 +232,7 @@ Proof.
   apply cate_buildequiv_fun.
 Defined.
 
-Definition id_cate_fun {A} `{HasEquivs A} (a : A) 
+Definition id_cate_fun {A} `{HasEquivs A} (a : A)
   : cate_fun (id_cate a) $== Id a.
 Proof.
   apply cate_buildequiv_fun.
@@ -206,6 +248,16 @@ Proof.
   - refine (_ $@L compose_cate_funinv g f).
 Defined.
 
+Definition compose_cate_assoc_opp {A} `{HasEquivs A}
+           {a b c d : A} (f : a $<~> b) (g : b $<~> c) (h : c $<~> d)
+  : cate_fun (h $oE (g $oE f)) $== cate_fun ((h $oE g) $oE f).
+Proof.
+  Opaque compose_catie_isretr.
+  (* We use [exact_no_check] just to save a small amount of time. *)
+  exact_no_check (compose_cate_assoc (A:=A^op) (a:=d) (b:=c) (c:=b) (d:=a) h g f).
+Defined.
+Transparent compose_catie_isretr.
+
 Definition compose_cate_idl {A} `{HasEquivs A}
            {a b : A} (f : a $<~> b)
   : cate_fun (id_cate b $oE f) $== cate_fun f.
@@ -216,11 +268,8 @@ Defined.
 
 Definition compose_cate_idr {A} `{HasEquivs A}
            {a b : A} (f : a $<~> b)
-  : cate_fun (f $oE id_cate a) $== cate_fun f.
-Proof.
-  refine (compose_cate_fun f _ $@ _ $@ cat_idr f).
-  refine (_ $@L cate_buildequiv_fun _).
-Defined.
+  : cate_fun (f $oE id_cate a) $== cate_fun f
+  := compose_cate_idl (A:=A^op) (a:=b) (b:=a) f.
 
 Global Instance transitive_cate {A} `{HasEquivs A}
   : Transitive (@CatEquiv A _ _ _ _ _)
@@ -230,11 +279,11 @@ Global Instance transitive_cate {A} `{HasEquivs A}
 
 Definition compose_V_hh {A} `{HasEquivs A} {a b c : A} (f : b $<~> c) (g : a $-> b) :
   f^-1$ $o (f $o g) $== g :=
-  (cat_assoc _ _ _)^$ $@ (cate_issect f $@R g) $@ cat_idl g.
+  (cat_assoc_opp _ _ _) $@ (cate_issect f $@R g) $@ cat_idl g.
 
 Definition compose_h_Vh {A} `{HasEquivs A} {a b c : A} (f : c $<~> b) (g : a $-> b) :
   f $o (f^-1$ $o g) $== g :=
-  (cat_assoc _ _ _)^$ $@ (cate_isretr f $@R g) $@ cat_idl g.
+  (cat_assoc_opp _ _ _) $@ (cate_isretr f $@R g) $@ cat_idl g.
 
 Definition compose_hh_V {A} `{HasEquivs A} {a b c : A} (f : b $-> c) (g : a $<~> b) :
   (f $o g) $o g^-1$ $== f :=
@@ -255,31 +304,73 @@ Proof.
 Defined.
 
 Definition cate_epic_equiv {A} `{HasEquivs A} {a b : A} (e : a $<~> b)
-  : Epic e.
-Proof.
-  intros c f g p.
-  refine ((compose_hh_V _ e)^$ $@ _ $@ compose_hh_V _ e).
-  exact (p $@R _).
-Defined.
+  : Epic e
+  := cate_monic_equiv (A:=A^op) (a:=b) (b:=a) e.
+
+(** ** Movement Lemmas *)
 
-(** Some lemmas for moving equivalences around.  Naming based on EquivGroupoids.v.  More could be added. *)
+(** These lemmas can be used to move equivalences around in an equation. *)
 
-Definition cate_moveR_eM {A} `{HasEquivs A} {a b c : A} (e : b $<~> a) (f : b $<~> c) (g : a $<~> c)
-  (p : cate_fun g $== f $o e^-1$)
-  : g $o e $== f.
+Definition cate_moveL_eM {A} `{HasEquivs A} {a b c : A}
+  (e : a $<~> b) (f : a $-> c) (g : b $-> c)
+  (p : f $o e^-1$ $== g)
+  : f $== g $o e.
+Proof.
+  apply (cate_epic_equiv e^-1$).
+  exact (p $@ (compose_hh_V _ _)^$).
+Defined.
+  
+Definition cate_moveR_eM {A} `{HasEquivs A} {a b c : A}
+  (e : b $<~> a) (f : a $-> c) (g : b $-> c)
+  (p : f $== g $o e^-1$)
+  : f $o e $== g.
 Proof.
   apply (cate_epic_equiv e^-1$).
   exact (compose_hh_V _ _ $@ p).
 Defined.
 
-Definition cate_moveR_Ve {A} `{HasEquivs A} {a b c : A} (e : b $<~> a) (f : b $<~> c) (g : c $<~> a)
-  (p : cate_fun e $== g $o f)
-  : g^-1$ $o e $== f.
+Definition cate_moveL_Me {A} `{HasEquivs A} {a b c : A}
+  (e : b $<~> c) (f : a $-> c) (g : a $-> b)
+  (p : e^-1$ $o f $== g)
+  : f $== e $o g
+  := cate_moveL_eM (A:=A^op) (a:=c) (b:=b) (c:=a) e f g p.
+
+Definition cate_moveR_Me {A} `{HasEquivs A} {a b c : A}
+  (e : c $<~> b) (f : a $-> c) (g : a $-> b)
+  (p : f $== e^-1$ $o g)
+  : e $o f $== g
+  := cate_moveR_eM (A:=A^op) (a:=c) (b:=b) (c:=a) e f g p.
+
+Definition cate_moveL_eV {A} `{HasEquivs A} {a b c : A}
+  (e : a $<~> b) (f : b $-> c) (g : a $-> c)
+  (p : f $o e $== g)
+  : f $== g $o e^-1$.
 Proof.
-  apply (cate_monic_equiv g).
-  exact (compose_h_Vh _ _ $@ p).
+  apply (cate_epic_equiv e).
+  exact (p $@ (compose_hV_h _ _)^$).
 Defined.
 
+Definition cate_moveR_eV {A} `{HasEquivs A} {a b c : A}
+  (e : b $<~> a) (f : b $-> c) (g : a $-> c)
+  (p : f $== g $o e)
+  : f $o e^-1$ $== g.
+Proof.
+  apply (cate_epic_equiv e).
+  exact (compose_hV_h _ _ $@ p).
+Defined.
+
+Definition cate_moveL_Ve {A} `{HasEquivs A} {a b c : A}
+  (e : b $<~> c) (f : a $-> b) (g : a $-> c)
+  (p : e $o f $== g)
+  : f $== e^-1$ $o g
+  := cate_moveL_eV (A:=A^op) (a:=c) (b:=b) (c:=a) e f g p.
+
+Definition cate_moveR_Ve {A} `{HasEquivs A} {a b c : A}
+  (e : b $<~> c) (f : a $-> c) (g : a $-> b)
+  (p : f $== e $o g)
+  : e^-1$ $o f $== g
+  := cate_moveR_eV (A:=A^op) (a:=b) (b:=c) (c:=a) e f g p.
+
 Definition cate_moveL_V1 {A} `{HasEquivs A} {a b : A} {e : a $<~> b} (f : b $-> a)
   (p : e $o f $== Id _)
   : f $== cate_fun e^-1$.
@@ -290,11 +381,8 @@ Defined.
 
 Definition cate_moveL_1V {A} `{HasEquivs A} {a b : A} {e : a $<~> b} (f : b $-> a)
   (p : f $o e $== Id _)
-  : f $== cate_fun e^-1$.
-Proof.
-  apply (cate_epic_equiv e).
-  exact (p $@ (cate_issect e)^$).
-Defined.
+  : f $== cate_fun e^-1$
+  := cate_moveL_V1 (A:=A^op) (a:=b) (b:=a) f p.
 
 Definition cate_moveR_V1 {A} `{HasEquivs A} {a b : A} {e : a $<~> b} (f : b $-> a)
   (p : Id _ $== e $o f)
@@ -306,11 +394,8 @@ Defined.
 
 Definition cate_moveR_1V {A} `{HasEquivs A} {a b : A} {e : a $<~> b} (f : b $-> a)
   (p : Id _ $== f $o e)
-  : cate_fun e^-1$ $== f.
-Proof.
-  apply (cate_epic_equiv e).
-  exact (cate_issect e $@ p).
-Defined.
+  : cate_fun e^-1$ $== f
+  := cate_moveR_V1 (A:=A^op) (a:=b) (b:=a) f p.
 
 (** Lemmas about the underlying map of an equivalence. *)
 
@@ -328,6 +413,13 @@ Proof.
   apply cate_inv_adjointify.
 Defined.
 
+Definition cate_inv_compose' {A} `{HasEquivs A} {a b c : A} (e : a $<~> b) (f : b $<~> c)
+  : cate_fun (f $oE e)^-1$ $== e^-1$ $o f^-1$.
+Proof.
+  nrefine (_ $@ cate_buildequiv_fun _).
+  nrapply cate_inv_compose.
+Defined.
+
 Definition cate_inv_V {A} `{HasEquivs A} {a b : A} (e : a $<~> b)
   : cate_fun (e^-1$)^-1$ $== cate_fun e.
 Proof.
@@ -392,6 +484,12 @@ Proof.
   exact (cate_buildequiv_fun _)^$.
 Defined.
 
+Definition emap_inv' {A B : Type} `{HasEquivs A} `{HasEquivs B}
+  (F : A -> B) `{!Is0Functor F, !Is1Functor F}
+  {a b : A} (e : a $<~> b)
+  : cate_fun (emap F e)^-1$ $== fmap F e^-1$
+  := emap_inv F e $@ cate_buildequiv_fun _.
+
 (** When we have equivalences, we can define what it means for a category to be univalent. *)
 Definition cat_equiv_path {A : Type} `{HasEquivs A} (a b : A)
   : (a = b) -> (a $<~> b).
@@ -481,6 +579,7 @@ Global Instance is1cat_core {A : Type} `{HasEquivs A}
 Proof.
   rapply Build_Is1Cat.
   - intros; apply compose_cate_assoc.
+  - intros; apply compose_cate_assoc_opp.
   - intros; apply compose_cate_idl.
   - intros; apply compose_cate_idr.
 Defined.
@@ -522,6 +621,18 @@ Proof.
   - exact tt.
 Defined.
 
+Global Instance hasmorext_core {A : Type} `{HasEquivs A, !HasMorExt A}
+  `{forall x y (f g : uncore x $<~> uncore y), IsEquiv (ap (x := f) (y := g) cate_fun)} 
+  : HasMorExt (core A).
+Proof.
+  snrapply Build_HasMorExt.
+  intros X Y f g; cbn in *.
+  snrapply isequiv_homotopic.
+  - exact (GpdHom_path o (ap (x:=f) (y:=g) cate_fun)).
+  - rapply isequiv_compose.
+  - intro p; by induction p.
+Defined.
+
 (** * Initial objects and terminal objects are all respectively equivalent. *)
 
 Lemma cate_isinitial A `{HasEquivs A} (x y : A)
@@ -533,14 +644,9 @@ Proof.
   1: exact (((inx _).2 _)^$ $@ (inx _).2 _).
 Defined.
 
-Lemma cate_isterminal A `{HasEquivs A} (x y : A)
-  : IsTerminal x -> IsTerminal y -> x $<~> y.
-Proof.
-  intros tex tey.
-  srapply (cate_adjointify (tey x).1 (tex y).1).
-  1: exact (((tey _).2 _)^$ $@ (tey _).2 _).
-  1: exact (((tex _).2 _)^$ $@ (tex _).2 _).
-Defined.
+Definition cate_isterminal A `{HasEquivs A} (x y : A)
+  : IsTerminal x -> IsTerminal y -> y $<~> x
+  := cate_isinitial A^op x y.
 
 Lemma isinitial_cate A `{HasEquivs A} (x y : A)
   : x $<~> y -> IsInitial x -> IsInitial y.
@@ -553,16 +659,9 @@ Proof.
   exact ((inx z).2 _).
 Defined.
 
-Lemma isterminal_cate A `{HasEquivs A} (x y : A)
-  : x $<~> y -> IsTerminal x -> IsTerminal y.
-Proof.
-  intros f tex z.
-  exists (f $o (tex z).1).
-  intros g.
-  refine (_ $@ compose_h_Vh f _).
-  refine (_ $@L _).
-  exact ((tex z).2 _).
-Defined.
+Definition isterminal_cate A `{HasEquivs A} (x y : A)
+  : y $<~> x -> IsTerminal x -> IsTerminal y
+  := isinitial_cate A^op x y.
 
 (** * There is a default notion of equivalence for a 1-category, namely bi-invertibility. *)
 
@@ -575,12 +674,12 @@ Class Cat_IsBiInv {A} `{Is1Cat A} {x y : A} (f : x $-> y) := {
   cat_eissect' : cat_equiv_inv' $o f $== Id x;
 }.
 
-Arguments cat_equiv_inv {A}%type_scope { _ _ _ _ x y} f {_}.
-Arguments cat_eisretr {A}%type_scope { _ _ _ _ x y} f {_}.
-Arguments cat_equiv_inv' {A}%type_scope { _ _ _ _ x y} f {_}.
-Arguments cat_eissect' {A}%type_scope { _ _ _ _ x y} f {_}.
+Arguments cat_equiv_inv {A}%_type_scope { _ _ _ _ x y} f {_}.
+Arguments cat_eisretr {A}%_type_scope { _ _ _ _ x y} f {_}.
+Arguments cat_equiv_inv' {A}%_type_scope { _ _ _ _ x y} f {_}.
+Arguments cat_eissect' {A}%_type_scope { _ _ _ _ x y} f {_}.
 
-Arguments Build_Cat_IsBiInv {A}%type_scope {_ _ _ _ x y f} cat_equiv_inv cat_eisretr cat_equiv_inv' cat_eissect'.
+Arguments Build_Cat_IsBiInv {A}%_type_scope {_ _ _ _ x y f} cat_equiv_inv cat_eisretr cat_equiv_inv' cat_eissect'.
 
 Record Cat_BiInv A `{Is1Cat A} (x y : A) := {
   cat_equiv_fun :> x $-> y;
diff --git a/theories/WildCat/EquivGpd.v b/theories/WildCat/EquivGpd.v
index 11dbc347be6..a9bda05d356 100644
--- a/theories/WildCat/EquivGpd.v
+++ b/theories/WildCat/EquivGpd.v
@@ -1,6 +1,6 @@
 (* -*- mode: coq; mode: visual-line -*-  *)
 
-Require Import Basics.Overture Basics.Tactics.
+Require Import Basics.Overture Basics.Tactics Basics.Iff.
 Require Import WildCat.Core.
 Require Import WildCat.NatTrans.
 Require Import WildCat.Sigma.
diff --git a/theories/WildCat/Forall.v b/theories/WildCat/Forall.v
index cd000c3ae6d..25a76f84eb2 100644
--- a/theories/WildCat/Forall.v
+++ b/theories/WildCat/Forall.v
@@ -52,6 +52,7 @@ Proof.
     intros f g p a.
     exact (p a $@R h a).
   + intros w x y z f g h a; apply cat_assoc.
+  + intros w x y z f g h a; apply cat_assoc_opp.
   + intros x y f a; apply cat_idl.
   + intros x y f a; apply cat_idr.
 Defined.
diff --git a/theories/WildCat/FunctorCat.v b/theories/WildCat/FunctorCat.v
index 3ea393ef972..d9c3997a8ac 100644
--- a/theories/WildCat/FunctorCat.v
+++ b/theories/WildCat/FunctorCat.v
@@ -2,6 +2,7 @@
 
 Require Import Basics.Overture Basics.Tactics.
 Require Import WildCat.Core.
+Require Import WildCat.Opposite.
 Require Import WildCat.Equiv.
 Require Import WildCat.Induced.
 Require Import WildCat.NatTrans.
@@ -36,9 +37,9 @@ Global Instance is01cat_fun01 (A B : Type) `{IsGraph A} `{Is1Cat B} : Is01Cat (F
 Proof.
   srapply Build_Is01Cat.
   - intros [F ?]; cbn.
-    exists (id_transformation F); exact _.
-  - intros [F ?] [G ?] [K ?] [gamma ?] [alpha ?]; cbn in *.
-    exists (trans_comp gamma alpha); exact _.
+    exact (nattrans_id F).
+  - intros F G K gamma alpha; cbn in *.
+    exact (nattrans_comp gamma alpha).
 Defined.
 
 Global Instance is2graph_fun01 (A B : Type) `{IsGraph A, Is1Cat B}
@@ -72,6 +73,8 @@ Proof.
     exact (f a $@R alpha a).
   - intros [F ?] [G ?] [K ?] [L ?] [alpha ?] [gamma ?] [phi ?] a; cbn.
     srapply cat_assoc.
+  - intros [F ?] [G ?] [K ?] [L ?] [alpha ?] [gamma ?] [phi ?] a; cbn.
+    srapply cat_assoc_opp.
   - intros [F ?] [G ?] [alpha ?] a; cbn.
     srapply cat_idl.
   - intros [F ?] [G ?] [alpha ?] a; cbn.
@@ -84,35 +87,28 @@ Global Instance hasequivs_fun01 (A B : Type) `{Is01Cat A} `{HasEquivs B}
   : HasEquivs (Fun01 A B).
 Proof.
   srapply Build_HasEquivs.
-  1:{ intros [F ?] [G ?]. exact (NatEquiv F G). }
-  1:{ intros [F ?] [G ?] [alpha ?]; cbn in *.
-      exact (forall a, CatIsEquiv (alpha a)). }
-  all:intros [F ?] [G ?] [alpha alnat]; cbn in *.
-  - exists (fun a => alpha a); assumption.
+  1: intros F G; exact (NatEquiv F G).
+  all: intros F G alpha; cbn in *.
+  - exact (forall a, CatIsEquiv (alpha a)).
+  - exact alpha.
   - intros a; exact _.
-  - intros ?.
-    snrapply Build_NatEquiv.
-    + intros a; exact (Build_CatEquiv (alpha a)).
-    + cbn. refine (is1natural_homotopic alpha _).
-      intros a; apply cate_buildequiv_fun.
+  - apply Build_NatEquiv'.
   - cbn; intros; apply cate_buildequiv_fun.
-  - exists (fun a => (alpha a)^-1$).
-    intros a b f.
-    refine ((cat_idr _)^$ $@ _).
-    refine ((_ $@L (cate_isretr (alpha a))^$) $@ _).
-    refine (cat_assoc _ _ _ $@ _).
-    refine ((_ $@L (cat_assoc_opp _ _ _)) $@ _).
-    refine ((_ $@L ((isnat (fun a => alpha a) f)^$ $@R _)) $@ _).
-    refine ((_ $@L (cat_assoc _ _ _)) $@ _).
-    refine (cat_assoc_opp _ _ _ $@ _).
-    refine ((cate_issect (alpha b) $@R _) $@ _).
-    exact (cat_idl _).
+  - exact (natequiv_inverse alpha).
   - intros; apply cate_issect.
   - intros; apply cate_isretr.
   - intros [gamma ?] r s a; cbn in *.
     refine (catie_adjointify (alpha a) (gamma a) (r a) (s a)).
 Defined.
 
+(** Bundled opposite functors *)
+Definition fun01_op (A B : Type) `{IsGraph A} `{IsGraph B}
+  : Fun01 A B -> Fun01 A^op B^op.
+Proof.
+  intros F.
+  rapply (Build_Fun01 A^op B^op F).
+Defined.
+
 (** ** Categories of 1-coherent 1-functors *)
 
 Record Fun11 (A B : Type) `{Is1Cat A} `{Is1Cat B} :=
diff --git a/theories/WildCat/Induced.v b/theories/WildCat/Induced.v
index 7635d1ece14..0e9dd18c269 100644
--- a/theories/WildCat/Induced.v
+++ b/theories/WildCat/Induced.v
@@ -57,6 +57,7 @@ Section Induced_category.
     + rapply is0functor_postcomp.
     + rapply is0functor_precomp.
     + rapply cat_assoc.
+    + rapply cat_assoc_opp.
     + rapply cat_idl.
     + rapply cat_idr.
   Defined.
diff --git a/theories/WildCat/Monoidal.v b/theories/WildCat/Monoidal.v
index 4200aefe8ef..cddad657443 100644
--- a/theories/WildCat/Monoidal.v
+++ b/theories/WildCat/Monoidal.v
@@ -1,85 +1,1046 @@
-Require Import Basics.Utf8 Basics.Overture Basics.Tactics.
-Require Import Types.Forall.
-Require Import WildCat.Core WildCat.Prod WildCat.Bifunctor
-  WildCat.Equiv WildCat.NatTrans.
-
-Section Monoidal.
-  Context (C : Type).
-  Context `{Is1Cat C}.
-  Context `{HasEquivs C}.
-  Context (tensor : C -> C -> C).
-  Context `{!IsBifunctor tensor}.
-
-  Definition left_assoc : C -> C -> C -> C :=
-    fun a b c => tensor (tensor a b) c.
-  
-  Definition right_assoc : C -> C -> C -> C :=
-    fun a b c => tensor a (tensor b c).
+Require Import Basics.Overture Basics.Tactics Types.Forall.
+Require Import WildCat.Core WildCat.Bifunctor WildCat.Prod WildCat.Equiv.
+Require Import WildCat.NatTrans WildCat.Square WildCat.Opposite.
 
-  Let right_assoc' := uncurry (uncurry (right_assoc)).
-  Let left_assoc' := uncurry (uncurry (left_assoc)).
-  
-  #[export] Instance Is0Functor_right_assoc
-    : Is0Functor right_assoc'.
+(** * Monoidal Categories *)
+
+(** In this file we define monoidal categories and symmetric monoidal categories. *)
+
+(** ** Typeclasses for common diagrams *)
+
+(** TODO: These should eventually be moved to a separate file in WildCat and used in other places. They can be thought of as a wildcat generalization of the classes in canonical_names.v *)
+
+(** *** Associators *)
+
+Class Associator {A : Type} `{HasEquivs A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  := associator_uncurried
+    : NatEquiv (fun '(a, b, c) => F a (F b c)) (fun '(a, b, c) => F (F a b) c).
+
+Arguments associator_uncurried {A _ _ _ _ _ F _ _ _}.
+
+Definition associator {A : Type} `{HasEquivs A} {F : A -> A -> A}
+  `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F}
+  : forall a b c, F a (F b c) $<~> F (F a b) c
+  := fun a b c => associator_uncurried (a, b, c).
+Coercion associator : Associator >-> Funclass.
+
+Definition Build_Associator {A : Type} `{HasEquivs A} (F : A -> A -> A)
+  `{!Is0Bifunctor F, !Is1Bifunctor F}
+  (associator : forall a b c, F a (F b c) $<~> F (F a b) c)
+  (isnat_assoc : Is1Natural
+    (fun '(a, b, c) => F a (F b c))
+    (fun '(a, b, c) => F (F a b) c)
+    (fun '(a, b, c) => associator a b c))
+  : Associator F.
+Proof.
+  snrapply Build_NatEquiv.
+  - intros [[a b] c].
+    exact (associator a b c).
+  - exact isnat_assoc.
+Defined. 
+
+(** *** Unitors *)
+
+Class LeftUnitor {A : Type} `{HasEquivs A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (unit : A)
+  (** A natural isomorphism [left_unitor] witnessing the left unit law of [F]. *)
+  := left_unitor : NatEquiv (F unit) idmap.
+Coercion left_unitor : LeftUnitor >-> NatEquiv.
+Arguments left_unitor {A _ _ _ _ _ F _ _ unit _}.
+
+Class RightUnitor {A : Type} `{HasEquivs A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} (unit : A)
+  (** A natural isomorphism [right_unitor] witnessing the right unit law of [F]. *)
+  := right_unitor : NatEquiv (flip F unit) idmap.
+Coercion right_unitor : RightUnitor >-> NatEquiv.
+Arguments right_unitor {A _ _ _ _ _ F _ _ unit _}.
+
+(** *** Triangle and Pentagon identities *)
+
+Class TriangleIdentity {A : Type} `{HasEquivs A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F}
+  (unit : A) `{!LeftUnitor F unit, !RightUnitor F unit}
+  (** The triangle identity for an associator and unitors. *)
+  := triangle_identity a b
+    : fmap01 F a (left_unitor b)
+    $== fmap10 F (right_unitor a) b $o (associator (F := F) a unit b).
+Coercion triangle_identity : TriangleIdentity >-> Funclass.
+Arguments triangle_identity {A _ _ _ _ _} F {_ _ _} unit {_}.
+
+Class PentagonIdentity {A : Type} `{HasEquivs A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F}
+  (** The pentagon identity for an associator. *)
+  := pentagon_identity a b c d
+    : associator (F a b) c d $o associator a b (F c d)
+      $== fmap10 F (associator a b c) d $o associator a (F b c) d
+        $o fmap01 F a (associator b c d).
+Coercion pentagon_identity : PentagonIdentity >-> Funclass.
+Arguments pentagon_identity {A _ _ _ _ _} F {_ _ _}.
+
+(** *** Braiding *)
+
+Class Braiding {A : Type} `{Is1Cat A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F}
+  := braid_uncurried : NatTrans (uncurry F) (uncurry (flip F)).
+
+Arguments braid_uncurried {A _ _ _ _ F _ _ _}.
+    
+Definition braid {A : Type} `{Is1Cat A} {F : A -> A -> A}
+  `{!Is0Bifunctor F, !Is1Bifunctor F, !Braiding F}
+  : forall a b, F a b $-> F b a
+  := fun a b => braid_uncurried (a, b).
+Coercion braid : Braiding >-> Funclass.
+
+Class SymmetricBraiding {A : Type} `{Is1Cat A}
+  (F : A -> A -> A) `{!Is0Bifunctor F, !Is1Bifunctor F} := {
+  braiding_symmetricbraiding :: Braiding F;
+  braid_braid : forall a b, braid a b $o braid b a $== Id (F b a);
+}.
+(** We could have used [::>] in [braiding_symmetricbraiding] instead however due to bug https://github.com/coq/coq/issues/18971 the coercion isn't registered, so we have to register it manually instead. *)
+Coercion braiding_symmetricbraiding : SymmetricBraiding >-> Braiding.
+Arguments braid_braid {A _ _ _ _ F _ _ _} a b.
+
+(** *** Hexagon identity *)
+
+Class HexagonIdentity {A : Type} `{HasEquivs A}
+  (F : A -> A -> A)
+  `{!Is0Bifunctor F, !Is1Bifunctor F, !Associator F, !Braiding F}
+  (** The hexagon identity for an associator and a braiding. *)
+  := hexagon_identity a b c
+    : fmap10 F (braid b a) c $o associator b a c $o fmap01 F b (braid c a)
+      $== associator a b c $o braid (F b c) a $o associator b c a.
+Coercion hexagon_identity : HexagonIdentity >-> Funclass.
+Arguments hexagon_identity {A _ _ _ _ _} F {_ _}.
+
+(** ** Monoidal Categories *)
+
+(** A monoidal 1-category is a 1-category with equivalences together with the following: *)
+Class IsMonoidal (A : Type) `{HasEquivs A}
+  (** It has a binary operation [cat_tensor] called the tensor product. *)
+  (cat_tensor : A -> A -> A)
+  (** It has a unit object [cat_tensor_unit] called the tensor unit. *)
+  (cat_tensor_unit : A)
+  (** These all satisfy the following properties: *)
+  := {
+  (** A [cat_tensor] is a 1-bifunctor. *)
+  is0bifunctor_cat_tensor : Is0Bifunctor cat_tensor;
+  is1bifunctor_cat_tensor : Is1Bifunctor cat_tensor;
+  (** A natural isomorphism [associator] witnessing the associativity of the tensor product. *)
+  cat_tensor_associator :: Associator cat_tensor;
+  (** A natural isomorphism [left_unitor] witnessing the left unit law. *)
+  cat_tensor_left_unitor :: LeftUnitor cat_tensor cat_tensor_unit;
+  (** A natural isomorphism [right_unitor] witnessing the right unit law. *)
+  cat_tensor_right_unitor :: RightUnitor cat_tensor cat_tensor_unit;
+  (** The triangle identity. *)
+  cat_tensor_triangle_identity :: TriangleIdentity cat_tensor cat_tensor_unit;
+  (** The pentagon identity. *)
+  cat_tensor_pentagon_identity :: PentagonIdentity cat_tensor;
+}.
+
+Existing Instance is0bifunctor_cat_tensor | 10.
+Existing Instance is1bifunctor_cat_tensor | 10.
+
+(** TODO: Braided monoidal categories *)
+
+(** ** Symmetric Monoidal Categories *)
+
+(** A symmetric monoidal 1-category is a 1-category with equivalences together with the following: *)
+Class IsSymmetricMonoidal (A : Type) `{HasEquivs A}
+  (** A binary operation [cat_tensor] called the tensor product. *)
+  (cat_tensor : A -> A -> A)
+  (** A unit object [cat_tensor_unit] called the tensor unit. *)
+  (cat_tensor_unit : A)
+  := {
+  (** A monoidal structure with [cat_tensor] and [cat_tensor_unit]. *)
+  issymmetricmonoidal_ismonoidal :: IsMonoidal A cat_tensor cat_tensor_unit;
+  (** A natural transformation [braid] witnessing the symmetry of the tensor product such that [braid] is its own inverse. *)
+  cat_symm_tensor_braiding :: SymmetricBraiding cat_tensor;
+  (** The hexagon identity. *)
+  cat_symm_tensor_hexagon :: HexagonIdentity cat_tensor;
+}.
+
+(** *** Theory about [Associator] *)
+
+Section Associator.
+  Context {A : Type} `{HasEquivs A} {F : A -> A -> A}
+    `{!Is0Bifunctor F, !Is1Bifunctor F, assoc : !Associator F}.
+
+  Local Definition associator_nat {x x' y y' z z'}
+    (f : x $-> x') (g : y $-> y') (h : z $-> z')
+    : associator x' y' z' $o fmap11 F f (fmap11 F g h)
+      $== fmap11 F (fmap11 F f g) h $o associator x y z.
   Proof.
-    srapply Build_Is0Functor.
-    intros [[a1 b1] c1] [[a2 b2] c2] [[f g] h];
-      cbn in f, g, h.
-    exact (fmap11 tensor f (fmap11 tensor g h)).
+    destruct assoc as [asso nat].
+    exact (nat (x, y, z) (x', y', z') (f, g, h)).
   Defined.
 
-  #[export] Instance Is0Functor_left_assoc : Is0Functor left_assoc'.
+  Local Definition associator_nat_l {x x' : A} (f : x $-> x') (y z : A)
+    : associator x' y z $o fmap10 F f (F y z)
+      $== fmap10 F (fmap10 F f y) z $o associator x y z.
   Proof.
-    srapply Build_Is0Functor.
-    intros [[a1 b1] c1] [[a2 b2] c2] [[f g] h];
-      cbn in f, g, h.
-    exact (fmap11 tensor (fmap11 tensor f g) h).
+    refine ((_ $@L _^$) $@ _ $@ (_ $@R _)).
+    2: rapply (associator_nat f (Id _) (Id _)).
+    - exact (fmap12 _ _ (fmap11_id _ _ _) $@ fmap10_is_fmap11 _ _ _).
+    - exact (fmap21 _ (fmap10_is_fmap11 _ _ _) _ $@ fmap10_is_fmap11 _ _ _).
   Defined.
 
-  (* Left to right is the convention in Mac Lane. *)
-  Class Associator := assoc : NatEquiv right_assoc' left_assoc'.
+  Local Definition associator_nat_m (x : A) {y y' : A} (g : y $-> y') (z : A)
+    : associator x y' z $o fmap01 F x (fmap10 F g z)
+      $== fmap10 F (fmap01 F x g) z $o associator x y z.
+  Proof.
+    refine ((_ $@L _^$) $@ _ $@ (_ $@R _)).
+    2: nrapply (associator_nat (Id _) g (Id _)).
+    - exact (fmap12 _ _ (fmap10_is_fmap11 _ _ _) $@ fmap01_is_fmap11 _ _ _).
+    - exact (fmap21 _ (fmap01_is_fmap11 _ _ _) _ $@ fmap10_is_fmap11 _ _ _).
+  Defined.
+
+  Local Definition associator_nat_r (x y : A) {z z' : A} (h : z $-> z')
+    : associator x y z' $o fmap01 F x (fmap01 F y h)
+      $== fmap01 F (F x y) h $o associator x y z.
+  Proof.
+    refine ((_ $@L _^$) $@ _ $@ (_ $@R _)).
+    2: nrapply (associator_nat (Id _) (Id _) h).
+    - exact (fmap12 _ _ (fmap01_is_fmap11 _ _ _) $@ fmap01_is_fmap11 _ _ _).
+    - exact (fmap21 _ (fmap11_id _ _ _) _ $@ fmap01_is_fmap11 F _ _).
+  Defined.
+
+  Global Instance associator_op : Associator (A:=A^op) F
+    := natequiv_inverse (natequiv_op assoc).
+
+End Associator.
 
-  Notation "a ⊗ b" := (tensor a b).
+Definition associator_op' {A : Type} `{HasEquivs A} {F : A -> A -> A}
+  `{!Is0Bifunctor F, !Is1Bifunctor F, assoc : !Associator (A:=A^op) F}
+  : Associator F
+  := associator_op (A:=A^op) (assoc := assoc).
+
+(** ** Theory about [LeftUnitor] and [RightUnitor] *)
+
+Section LeftUnitor.
+  Context {A : Type} `{HasEquivs A} {F : A -> A -> A} (unit : A)
+    `{!Is0Bifunctor F, !Is1Bifunctor F, !LeftUnitor F unit, !RightUnitor F unit}.
+
+  Global Instance left_unitor_op : LeftUnitor (A:=A^op) F unit
+    := natequiv_inverse (natequiv_op left_unitor).
   
-  Definition PentagonLaw `{Associator} (a b c d : C) :=
-    (assoc (a ⊗ b, c, d)) $o (assoc (a, b, c ⊗ d)) $==
-      (fmap (flip tensor d) (assoc (a, b, c)))  
-      $o assoc (a, b ⊗ c, d) $o (fmap (tensor a) (assoc (b, c, d))).
-    
-  Context (I : C).
+  Global Instance right_unitor_op : RightUnitor (A:=A^op) F unit
+    := natequiv_inverse (natequiv_op right_unitor).
+
+End LeftUnitor.
+
+(** ** Theory about [Braiding] *)
+
+Global Instance braiding_op {A : Type} `{HasEquivs A} {F : A -> A -> A}
+  `{!Is0Bifunctor F, !Is1Bifunctor F, braid : !Braiding F}
+  : Braiding (A:=A^op) F
+  := nattrans_op (nattrans_flip braid).
+
+Definition braiding_op' {A : Type} `{HasEquivs A} {F : A -> A -> A}
+  `{!Is0Bifunctor F, !Is1Bifunctor F, braid : !Braiding (A:=A^op) F}
+  : Braiding F
+  := braiding_op (A:=A^op) (braid := braid).
+
+(** ** Theory about [SymmetricBraid] *)
+
+Section SymmetricBraid.
+  Context {A : Type} {F : A -> A -> A} `{SymmetricBraiding A F, !HasEquivs A}.
+
+  (** [braid] is its own inverse and therefore an equivalence. *)
+  Local Instance catie_braid a b : CatIsEquiv (braid a b)
+    := catie_adjointify (braid a b) (braid b a) (braid_braid a b) (braid_braid b a).
+
+  (** [braide] is the bundled equivalence whose underlying map is [braid]. *)
+  Definition braide a b
+    : F a b $<~> F b a
+    := Build_CatEquiv (braid a b).
+
+  Local Definition moveL_braidL a b c f (g : c $-> _)
+    : braid a b $o f $== g -> f $== braid b a $o g.
+  Proof.
+    intros p.
+    apply (cate_monic_equiv (braide a b)).
+    refine ((cate_buildequiv_fun _ $@R _) $@ p $@ _ $@ cat_assoc _ _ _).
+    refine ((cat_idl _)^$ $@ (_^$ $@R _)).
+    refine ((cate_buildequiv_fun _ $@R _) $@ _).
+    apply braid_braid.
+  Defined.
+
+  Local Definition moveL_braidR a b c f (g : _ $-> c)
+    : f $o braid a b $== g -> f $== g $o braid b a.
+  Proof.
+    intros p.
+    apply (cate_epic_equiv (braide a b)).
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ (_ $@L ((_ $@L cate_buildequiv_fun _) $@ _)^$)).
+    2: apply braid_braid.
+    refine ((_ $@L _) $@ _ $@ (cat_idr _)^$).
+    1: apply cate_buildequiv_fun.
+    exact p.
+  Defined.
+
+  Local Definition moveR_braidL a b c f (g : c $-> _)
+    : f $== braid b a $o g -> braid a b $o f $== g.
+  Proof.
+    intros p; symmetry; apply moveL_braidL; symmetry; exact p.
+  Defined.
+
+  Local Definition moveR_braidR a b c f (g : _ $-> c)
+    : f $== g $o braid b a -> f $o braid a b $== g.
+  Proof.
+    intros p; symmetry; apply moveL_braidR; symmetry; exact p.
+  Defined.
+
+  Local Definition moveL_fmap01_braidL a b c d f (g : d $-> _)
+    : fmap01 F a (braid b c) $o f $== g
+      -> f $== fmap01 F a (braid c b) $o g.
+  Proof.
+    intros p.
+    apply (cate_monic_equiv (emap01 F a (braide b c))).
+    refine (_ $@ cat_assoc _ _ _).
+    refine (_ $@ (_ $@R _)).
+    2: { refine (_ $@ (_^$ $@R _)).
+      2: apply cate_buildequiv_fun.
+      refine ((fmap_id _ _)^$ $@ fmap2 _ _ $@ fmap_comp _ _ _).
+      refine ((_ $@R _) $@ _)^$.
+      1: apply cate_buildequiv_fun.
+      apply braid_braid. }
+    refine ((_ $@R _) $@ p $@ (cat_idl _)^$).
+    refine (_ $@ fmap2 _ _);
+    apply cate_buildequiv_fun.
+  Defined.
+
+  Local Definition moveL_fmap01_braidR a b c d f (g : _ $-> d)
+    :  f $o fmap01 F a (braid b c) $== g
+      -> f $== g $o fmap01 F a (braid c b).
+  Proof.
+    intros p.
+    apply (cate_epic_equiv (emap01 F a (braide b c))).
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ (_ $@L _)).
+    2: { refine (_^$ $@ (_ $@L _^$)).
+      2: apply cate_buildequiv_fun.
+      refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _).
+      refine ((_ $@L _) $@ _).
+      1: apply cate_buildequiv_fun.
+      apply braid_braid. }
+    refine ((_ $@L _) $@ p $@ (cat_idr _)^$).
+    refine (_ $@ fmap2 _ _);
+    apply cate_buildequiv_fun.
+  Defined.
+
+  Local Definition moveR_fmap01_braidL a b c d f (g : d $-> _)
+    : f $== fmap01 F a (braid c b) $o g
+      -> fmap01 F a (braid b c) $o f $== g.
+  Proof.
+    intros p; symmetry; apply moveL_fmap01_braidL; symmetry; exact p.
+  Defined.
+
+  Local Definition moveR_fmap01_braidR a b c d f (g : _ $-> d)
+    : f $== g $o fmap01 F a (braid c b)
+      -> f $o fmap01 F a (braid b c) $== g.
+  Proof.
+    intros p; symmetry; apply moveL_fmap01_braidR; symmetry; exact p.
+  Defined.
+
+  Local Definition moveL_fmap01_fmap01_braidL a b c d e f (g : e $-> _)
+    : fmap01 F a (fmap01 F b (braid c d)) $o f $== g
+      -> f $== fmap01 F a (fmap01 F b (braid d c)) $o g.
+  Proof.
+    intros p.
+    apply (cate_monic_equiv (emap01 F a (emap01 F b (braide c d)))).
+    refine (_ $@ cat_assoc _ _ _).
+    refine (_ $@ (_ $@R _)).
+    2: { refine (_ $@ (_^$ $@R _)).
+      2: apply cate_buildequiv_fun.
+      refine ((fmap_id _ _)^$ $@ fmap2 _ _ $@ fmap_comp _ _ _).
+      refine (_ $@ (_^$ $@R _)).
+      2: apply cate_buildequiv_fun.
+      refine ((fmap_id _ _)^$ $@ fmap2 _ _ $@ fmap_comp _ _ _).
+      refine ((_ $@R _) $@ _)^$.
+      1: apply cate_buildequiv_fun.
+      apply braid_braid. }
+    refine ((_ $@R _) $@ p $@ (cat_idl _)^$).
+    refine (cate_buildequiv_fun _ $@ fmap02 _ _ _).
+    refine (cate_buildequiv_fun _ $@ fmap02 _ _ _).
+    apply cate_buildequiv_fun.
+  Defined.
+
+  Local Definition moveL_fmap01_fmap01_braidR a b c d e f (g : _ $-> e)
+    : f $o fmap01 F a (fmap01 F b (braid c d)) $== g
+      -> f $== g $o fmap01 F a (fmap01 F b (braid d c)).
+  Proof.
+    intros p.
+    apply (cate_epic_equiv (emap01 F a (emap01 F b (braide c d)))).
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ (_ $@L _)).
+    2: { refine (_^$ $@ (_ $@L _^$)).
+      2: apply cate_buildequiv_fun.
+      refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _).
+      refine ((_ $@L _) $@ _).
+      1: apply cate_buildequiv_fun.
+      refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _).
+      refine ((_ $@L _) $@ _).
+      1: apply cate_buildequiv_fun.
+      apply braid_braid. }
+    refine ((_ $@L _) $@ p $@ (cat_idr _)^$).
+    refine (cate_buildequiv_fun _ $@ fmap02 _ _ _).
+    refine (cate_buildequiv_fun _ $@ fmap02 _ _ _).
+    apply cate_buildequiv_fun.
+  Defined.
+
+  Local Definition moveR_fmap01_fmap01_braidL a b c d e f (g : e $-> _)
+    : f $== fmap01 F a (fmap01 F b (braid d c)) $o g
+      -> fmap01 F a (fmap01 F b (braid c d)) $o f $== g.
+  Proof.
+    intros p; symmetry; apply moveL_fmap01_fmap01_braidL; symmetry; exact p.
+  Defined.
+
+  Local Definition moveR_fmap01_fmap01_braidR a b c d e f (g : _ $-> e)
+    : f $== g $o fmap01 F a (fmap01 F b (braid d c))
+      -> f $o fmap01 F a (fmap01 F b (braid c d)) $== g.
+  Proof.
+    intros p; symmetry; apply moveL_fmap01_fmap01_braidR; symmetry; exact p.
+  Defined.
+
+  Local Definition braid_nat {a b c d} (f : a $-> c) (g : b $-> d)
+    : braid c d $o fmap11 F f g $== fmap11 F g f $o braid a b.
+  Proof.
+    exact (isnat braid_uncurried (a := (a, b)) (a' := (c, d)) (f, g)).
+  Defined.
+
+  Local Definition braid_nat_l {a b c} (f : a $-> b)
+    : braid b c $o fmap10 F f c $== fmap01 F c f $o braid a c.
+  Proof.
+    refine ((_ $@L (fmap10_is_fmap11 _ _ _)^$) $@ _ $@ (fmap01_is_fmap11 _ _ _ $@R _)).
+    exact (isnat braid_uncurried (a := (a, c)) (a' := (b, c)) (f, Id _)).
+  Defined.
+
+  (** This is just the inverse of above. *)
+  Local Definition braid_nat_r {a b c} (g : b $-> c)
+    : braid a c $o fmap01 F a g $== fmap10 F g a $o braid a b.
+  Proof.
+    refine ((_ $@L (fmap01_is_fmap11 _ _ _)^$) $@ _ $@ (fmap10_is_fmap11 _ _ _ $@R _)).
+    exact (isnat braid_uncurried (a := (a, b)) (a' := (a, c)) (Id _ , g)).
+  Defined.
   
-  Class LeftUnitor := left_unitor : NatEquiv (tensor I) idmap.
-
-  Class RightUnitor := right_unitor : NatEquiv (flip tensor I) idmap.
-
-  Definition TriangleLaw {assoc : Associator}
-    `{LeftUnitor} `{RightUnitor} (a c : C)
-    :=  fmap (tensor a) (left_unitor c)
-    $== fmap (flip tensor c) (right_unitor a) $o assoc (a, I, c).
-               
-  Class MonoidalStructure
-    `{forall a, Is1Functor (tensor a)}
-    `{forall b, Is1Functor (flip tensor b)}
-    {assoc : Associator}
-    {left_unitor : LeftUnitor}
-    {right_unitor : RightUnitor}
-    := {
-      pentagon_law : forall a b c d : C, PentagonLaw a b c d;
-      triangle_law : forall a c : C, TriangleLaw a c
-    }.
-
-  (** TODO *)
-  Proposition left_unitor_associator_coherence
-    `{M : MonoidalStructure} (x y : C)
-    : fmap (flip tensor y) (left_unitor x) $o
-        assoc (I, x ,y) $== left_unitor (x ⊗ y).
-  Proof.
-    Abort.
-    
-  (** TODO *)
-  Proposition left_right_unitor_agree `{M : MonoidalStructure}
-    : cate_fun (left_unitor I) $== cate_fun (right_unitor I).
+  Global Instance symmetricbraiding_op : SymmetricBraiding (A:=A^op) F.
   Proof.
-    Abort.
-    
-End Monoidal.
+    snrapply Build_SymmetricBraiding.
+    - exact _.
+    - intros a b.
+      rapply braid_braid.
+  Defined.
+
+End SymmetricBraid.
+
+Definition symmetricbraiding_op' {A : Type} {F : A -> A -> A}
+  `{HasEquivs A, !Is0Bifunctor F, !Is1Bifunctor F,
+    H' : !SymmetricBraiding (A:=A^op) F}
+  : SymmetricBraiding F
+  := symmetricbraiding_op (A:=A^op) (F := F).
+
+(** ** Opposite Monoidal Categories *)
+
+Global Instance ismonoidal_op {A : Type} (tensor : A -> A -> A) (unit : A)
+  `{IsMonoidal A tensor unit}
+  : IsMonoidal A^op tensor unit.
+Proof.
+  snrapply Build_IsMonoidal.
+  1-5: exact _.
+  - intros a b; unfold op in a, b; simpl.
+    refine (_^$ $@ _ $@ (_ $@L _)).
+    1,3: exact (emap_inv _ _ $@ cate_buildequiv_fun _).
+    nrefine (cate_inv2 _ $@ cate_inv_compose' _ _).
+    refine (cate_buildequiv_fun _ $@ _ $@ ((cate_buildequiv_fun _)^$ $@R _)
+      $@ (cate_buildequiv_fun _)^$).
+    rapply cat_tensor_triangle_identity.
+  - intros a b c d; unfold op in a, b, c, d; simpl.
+    refine (_ $@ ((_ $@L _) $@@ _)).
+    2,3: exact (emap_inv _ _ $@ cate_buildequiv_fun _).
+    refine ((cate_inv_compose' _ _)^$ $@ cate_inv2 _ $@ cate_inv_compose' _ _
+      $@ (_ $@L cate_inv_compose' _ _)). 
+    refine (cate_buildequiv_fun _ $@ _ $@ ((cate_buildequiv_fun _)^$ $@R _)
+      $@ (cate_buildequiv_fun _)^$).
+    refine (_ $@ (cate_buildequiv_fun _ $@@ (cate_buildequiv_fun _ $@R _))^$).
+    rapply cat_tensor_pentagon_identity.
+Defined.
+
+Definition ismonoidal_op' {A : Type} (tensor : A -> A -> A) (unit : A)
+  `{HasEquivs A} `{!IsMonoidal A^op tensor unit}
+  : IsMonoidal A tensor unit
+  := ismonoidal_op (A:=A^op) tensor unit.
+
+Global Instance issymmetricmonoidal_op {A : Type} (tensor : A -> A -> A) (unit : A)
+  `{IsSymmetricMonoidal A tensor unit}
+  : IsSymmetricMonoidal A^op tensor unit.
+Proof.
+  snrapply Build_IsSymmetricMonoidal.
+  - rapply ismonoidal_op.
+  - rapply symmetricbraiding_op.
+  - intros a b c; unfold op in a, b, c; simpl.
+    snrefine (_ $@ (_ $@L (_ $@R _))).
+    2: exact ((braide _ _)^-1$).
+    2: { nrapply cate_moveR_V1.
+      symmetry.
+      nrefine ((_ $@R _) $@ _).
+      1: nrapply cate_buildequiv_fun.
+      rapply braid_braid. }
+    snrefine ((_ $@R _) $@ _).
+    { refine (emap _ _)^-1$.
+      rapply braide. }
+    { symmetry.
+      refine (cate_inv_adjointify _ _ _ _ $@ fmap2 _ _).
+      nrapply cate_inv_adjointify. }
+    snrefine ((_ $@L (_ $@L _)) $@ _).
+    { refine (emap (flip tensor c) _)^-1$.
+      rapply braide. }
+    { symmetry.
+      refine (cate_inv_adjointify _ _ _ _ $@ fmap2 _ _).
+      nrapply cate_inv_adjointify. }
+    refine ((_ $@L _)^$ $@ _^$ $@ cate_inv2 _ $@ _ $@ (_ $@L _)).
+    1,2,4,5: rapply cate_inv_compose'.
+    refine (_ $@ (_ $@@ _) $@ _ $@ (_ $@R _)^$ $@ _^$).
+    1-3,5-6: rapply cate_buildequiv_fun.
+    refine ((fmap02 _ _ _ $@@ ((_ $@ fmap20 _ _ _) $@R _)) $@ cat_symm_tensor_hexagon a b c $@ ((_ $@L _^$) $@R _)).
+    1-4: nrapply cate_buildequiv_fun.
+Defined.
+
+Definition issymmetricmonoidal_op' {A : Type} (tensor : A -> A -> A) (unit : A)
+  `{HasEquivs A} `{H' : !IsSymmetricMonoidal A^op tensor unit}
+  : IsSymmetricMonoidal A tensor unit
+  := issymmetricmonoidal_op (A:=A^op) tensor unit.
+
+(** ** Further Coherence Conditions *)
+(** In MacLane's original axiomatisation of a monoidal category, 3 extra coherence conditions were given in addition to the pentagon and triangle identities. It was later shown by Kelly that these axioms are redundant and follow from the rest. We reproduce these arguments here. *)
+
+(** The left unitor of a tensor can be decomposed as an associator and a functorial action of the tensor on a left unitor. *)
+Definition left_unitor_associator {A} (tensor : A -> A -> A) (unit : A)
+  `{IsMonoidal A tensor unit} (x y : A)
+  : (left_unitor (tensor x y) : _ $-> _)
+    $== fmap10 tensor (left_unitor x) y $o associator unit x y.
+Proof.
+  refine ((cate_moveR_eV _ _ _ (isnat_natequiv left_unitor _))^$
+    $@ ((_ $@L _) $@R _) $@ cate_moveR_eV _ _ _ (isnat_natequiv left_unitor _)).
+  refine (_ $@ (fmap01_comp _ _ _ _)^$).
+  refine (_ $@ (cate_moveR_Ve _ _ _ (associator_nat_m _  _ _)^$ $@R _)).
+  nrefine (_ $@ cat_assoc_opp _ _ _).
+  change (fmap (tensor ?x) ?f) with (fmap01 tensor x f).
+  change (cate_fun' _ _ (cat_tensor_left_unitor ?x))
+    with (cate_fun (cat_tensor_left_unitor x)).
+  apply cate_moveL_Ve.
+  refine ((_ $@L triangle_identity _ _ _ _ _ _) $@ _).
+  nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc_opp _ _ _).
+  refine (_ $@ ((fmap20 _ (triangle_identity _ _ _ _ _ _) _
+    $@ fmap10_comp _ _ _ _)^$ $@R _)).
+  refine (_ $@ cat_assoc_opp _ _ _).
+  refine (_ $@ (_ $@L (pentagon_identity _ _ _ _ _ _ $@ cat_assoc _ _ _))).
+  refine ((_ $@R _) $@ cat_assoc _ _ _).
+  exact (associator_nat_l _ _ _).
+Defined.
+
+(** The right unitor of a tensor can be decomposed as an inverted associator and a functorial action of the tensor on a right unitor. *)
+Definition right_unitor_associator {A} (tensor : A -> A -> A) (unit : A)
+  `{IsMonoidal A tensor unit} (x y : A)
+  : (fmap01 tensor x (right_unitor y) : _ $-> _)
+    $== right_unitor (tensor x y) $o associator x y unit.
+Proof.
+  refine ((cate_moveR_eV _ _ _ (isnat_natequiv right_unitor _))^$
+    $@ ((_ $@L _) $@R _) $@ cate_moveR_eV _ _ _ (isnat_natequiv right_unitor _)).
+  refine (_ $@ (fmap10_comp tensor _ _ _)^$).
+  refine ((cate_moveR_eV _ _ _ (associator_nat_m _ _ _))^$ $@ _).
+  refine (_ $@ (cate_moveR_eV _ _ _ (triangle_identity _ _ _ _ _ _) $@R _)).
+  apply cate_moveR_eV.
+  refine ((_ $@L
+    (fmap02 _ _ (cate_moveR_eV _ _ _ (triangle_identity _ _ _ _ _ _))^$
+    $@ fmap01_comp _ _ _ _)) $@ _).
+  refine (cat_assoc_opp _ _ _ $@ _).
+  nrefine ((associator_nat_r _ _ _ $@R _) $@ cat_assoc _ _ _ $@ _).
+  do 2 nrefine (_ $@ cat_assoc_opp _ _ _).
+  refine (_ $@L _).
+  refine ((_ $@L (emap_inv' _ _)^$) $@ _).
+  apply cate_moveR_eV.
+  refine (_ $@ (_ $@L cate_buildequiv_fun _)^$).
+  nrefine (_ $@ cat_assoc_opp _ _ _).
+  apply cate_moveL_Ve.
+  rapply pentagon_identity.
+Defined.
+
+(** The left unitor at the unit is the right unitor at the unit. *)
+Definition left_unitor_unit_right_unitor_unit {A} (tensor : A -> A -> A) (unit : A)
+  `{IsMonoidal A tensor unit}
+  : (left_unitor unit : tensor unit unit $-> _) $== right_unitor unit.
+Proof.
+  refine ((cate_moveR_eV _ _ _ (isnat_natequiv left_unitor (left_unitor unit)))^$
+    $@ _).
+  apply cate_moveR_eV.
+  refine (_ $@ (_ $@L left_unitor_associator _ _ _ _)^$).
+  nrefine (_ $@ (_ $@R _) $@ cat_assoc _ _ _). 
+  2: rapply (isnat_natequiv right_unitor _)^$.
+  nrefine ((_ $@L _) $@ cat_assoc_opp _ _ _).
+  refine (triangle_identity _ _ _ _ _ _ $@ _).
+  nrefine (_ $@R _).
+  nrapply cate_monic_equiv.
+  exact (isnat_natequiv right_unitor (right_unitor unit)).
+Defined.
+
+(** TODO: Kelly also shows that there are redundant coherence conditions for symmetric monoidal categories also, but we leave these out for now. *)
+
+(** ** Building Symmetric Monoidal Categories *)
+
+(** The following construction is what we call the "twist construction". It is a way to build a symmetric monoidal category from simpler pieces than the axioms ask for.
+
+The core observation is that the associator can be broken up into a [braid] and what we call a [twist] map. The twist map takes a right associated triple [(A, (B, C))] and swaps the first two factors [(B, (A, C)]. Together with functoriality of the tensor and the braiding, here termed [braid] we can simplify the axioms we ask for.
+
+For instance, the hexagon identity is about associators, but if we unfold the definition and simplify the diagram, we get a diagram about only twists and braids.
+
+This means in practice, you can show a category has a symmetric monoidal structure by proving some simpler axioms. This idea has been used in TriJoin.v to show the associativity of join for example. *)
+
+Section TwistConstruction.
+  (** The aim of this section is to build a symmetric monoidal category. We do this piecewise so that the separate steps are useful in and of themselves.
+
+  Our basic starting assumption is that we have a category with equivalences, a bifunctor called the tensor product, and a unit object.*)
+  Context (A : Type) `{HasEquivs A}
+    (cat_tensor : A -> A -> A) (cat_tensor_unit : A)
+    `{!Is0Bifunctor cat_tensor, !Is1Bifunctor cat_tensor}
+
+    (** Next we postulate the existence of a [braid] map. This takes a tensor pair and swaps the factors. We also postulate that [braid] is natural in both factors and self-inverse. *)
+    (braid : SymmetricBraiding cat_tensor)
+
+    (** We postulate the existence of a [twist] map. This takes a right associated triple [(A, (B, C))] and swaps the first two factors [(B, (A, C)]. We also postulate that [twist] is natural in all three factors and self-inverse. *)
+    (twist : forall a b c, cat_tensor a (cat_tensor b c) $-> cat_tensor b (cat_tensor a c))
+    (twist_twist : forall a b c, twist a b c $o twist b a c $== Id _)
+    (twist_nat : forall a a' b b' c c' (f : a $-> a') (g : b $-> b') (h : c $-> c'),
+      twist a' b' c' $o fmap11 cat_tensor f (fmap11 cat_tensor g h)
+      $== fmap11 cat_tensor g (fmap11 cat_tensor f h) $o twist a b c)
+
+    (** We assume that there is a natural isomorphism [right_unitor] witnessing the right unit law. The left unit law will be derived from this one. We also assume a coherence called [twist_unitor] which determines how the right_unitor interacts with [braid] and [twist]. This is the basis of the triangle axiom. *)
+    (right_unitor : RightUnitor cat_tensor cat_tensor_unit)
+    (twist_unitor : forall a b, fmap01 cat_tensor a (right_unitor b)
+      $== braid b a $o fmap01 cat_tensor b (right_unitor a) $o twist a b cat_tensor_unit)
+
+    (** The hexagon identity is about the interaction of associators and braids. We will derive this axiom from an analogous one for twists and braids. *)
+    (twist_hexagon : forall a b c,
+      fmap01 cat_tensor c (braid b a) $o twist b c a $o fmap01 cat_tensor b (braid a c)
+      $== twist a c b $o fmap01 cat_tensor a (braid b c) $o twist b a c)
+
+    (** The 9-gon identity. TODO: explain this *)
+    (twist_9_gon : forall a b c d,
+        fmap01 cat_tensor c (braid (cat_tensor a b) d)
+        $o twist (cat_tensor a b) c d
+        $o braid (cat_tensor c d) (cat_tensor a b)
+        $o twist a (cat_tensor c d) b
+        $o fmap01 cat_tensor a (braid b (cat_tensor c d))
+      $== fmap01 cat_tensor c (twist a d b)
+        $o fmap01 cat_tensor c (fmap01 cat_tensor a (braid b d))
+        $o twist a c (cat_tensor b d)
+        $o fmap01 cat_tensor a (twist b c d))
+  .
+
+  (** *** Setup *)
+
+  (** Before starting the proofs, we need to setup some useful definitions and helpful lemmas for working with diagrams. *)
+
+  (** We give notations and abbreviations to the morphisms that will appear in diagrams. This helps us read the goal and understand what is happening, otherwise it is too verbose. *)
+  Declare Scope monoidal_scope.
+  Local Infix "⊗" := cat_tensor (at level 40) : monoidal_scope.
+  Local Infix "⊗R" := (fmap01 cat_tensor) (at level 40) : monoidal_scope.
+  Local Infix "⊗L" := (fmap10 cat_tensor) (at level 40) : monoidal_scope.
+  Local Notation "f ∘ g" := (f $o g) (at level 61, left associativity, format "f  '/' '∘'  g") : monoidal_scope.
+  Local Notation "f $== g :> A" := (GpdHom (A := A) f g)
+    (at level 80, format "'[v' '[v' f ']' '/'  $== '/'  '[v' g ']'  '/' :>  '[' A ']' ']'")
+    : long_path_scope.
+  Local Open Scope monoidal_scope.
+
+  (** [twist] is an equivalence which we will call [twiste]. *)
+  Local Definition twiste a b c
+    : cat_tensor a (cat_tensor b c) $<~> cat_tensor b (cat_tensor a c)
+    := cate_adjointify (twist a b c) (twist b a c)
+        (twist_twist a b c) (twist_twist b a c).
+
+  (** *** Finer naturality *)
+
+  (** The naturality postulates we have for [twist] are natural in all their arguments similtaneously. We show the finer naturality of [twist] in each argument separately as this becomes more useful in practice. *)
+
+  Local Definition twist_nat_l {a a'} (f : a $-> a') b c
+    : twist a' b c $o fmap10 cat_tensor f (cat_tensor b c)
+      $== fmap01 cat_tensor b (fmap10 cat_tensor f c) $o twist a b c.
+  Proof.
+    refine ((_ $@L _^$) $@ twist_nat a a' b b c c f (Id _) (Id _) $@ (_ $@R _)).
+    - refine (fmap12 _ _ _ $@ fmap10_is_fmap11 _ _ _).
+      rapply fmap11_id.
+    - refine (fmap12 _ _ _ $@ fmap01_is_fmap11 _ _ _).
+      rapply fmap10_is_fmap11.
+  Defined.
+
+  Local Definition twist_nat_m a {b b'} (g : b $-> b') c
+    : twist a b' c $o fmap01 cat_tensor a (fmap10 cat_tensor g c)
+      $== fmap10 cat_tensor g (cat_tensor a c) $o twist a b c.
+  Proof.
+    refine ((_ $@L _^$) $@ twist_nat a a b b' c c (Id _) g (Id _) $@ (_ $@R _)).
+    - refine (fmap12 _ _ _ $@ fmap01_is_fmap11 _ _ _).
+      rapply fmap10_is_fmap11.
+    - refine (fmap12 _ _ _ $@ fmap10_is_fmap11 _ _ _).
+      rapply fmap11_id.
+  Defined.
+
+  Local Definition twist_nat_r a b {c c'} (h : c $-> c')
+    : twist a b c' $o fmap01 cat_tensor a (fmap01 cat_tensor b h)
+      $== fmap01 cat_tensor b (fmap01 cat_tensor a h) $o twist a b c.
+  Proof.
+    refine ((_ $@L _^$) $@ twist_nat a a b b c c' (Id _) (Id _) h $@ (_ $@R _)).
+    - refine (fmap12 _ _ _ $@ fmap01_is_fmap11 _ _ _).
+      rapply fmap01_is_fmap11.
+    - refine (fmap12 _ _ _ $@ fmap01_is_fmap11 _ _ _).
+      rapply fmap01_is_fmap11.
+  Defined.
+
+  (** *** Movement lemmas *)
+
+  (** Here we collect lemmas about moving morphisms around in a diagram. We could have created [cate_moveL_eM]-style lemmas for [CatIsEquiv] but this leads to a lot of unnecessary unfolding and duplication. It is typically easier to use a hand crafted lemma for each situation. *)
+
+  (** TODO: A lot of these proofs are copy and pasted between lemmas. We need to work out an efficient way of proving them. *)
+
+  (** **** Moving [twist] *)
+
+  Local Definition moveL_twistL a b c d f (g : d $-> _)
+    : twist a b c $o f $== g -> f $== twist b a c $o g.
+  Proof.
+    intros p.
+    apply (cate_monic_equiv (twiste a b c)).
+    nrefine ((cate_buildequiv_fun _ $@R _) $@ p $@ _ $@ cat_assoc _ _ _).
+    refine ((cat_idl _)^$ $@ (_^$ $@R _)).
+    refine ((cate_buildequiv_fun _ $@R _) $@ _).
+    apply twist_twist.
+  Defined.
+
+  Local Definition moveL_twistR a b c d f (g : _ $-> d)
+    : f $o twist a b c $== g -> f $== g $o twist b a c.
+  Proof.
+    intros p.
+    apply (cate_epic_equiv (twiste a b c)).
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ (_ $@L ((_ $@L cate_buildequiv_fun _) $@ _)^$)).
+    2: apply twist_twist.
+    refine ((_ $@L _) $@ _ $@ (cat_idr _)^$).
+    1: apply cate_buildequiv_fun.
+    exact p.
+  Defined.
+
+  Local Definition moveR_twistL a b c d f (g : d $-> _)
+    : f $== twist b a c $o g -> twist a b c $o f $== g.
+  Proof.
+    intros p; symmetry; apply moveL_twistL; symmetry; exact p.
+  Defined.
+
+  Local Definition moveR_twistR a b c d f (g : _ $-> d)
+    : f $== g $o twist b a c -> f $o twist a b c $== g.
+  Proof.
+    intros p; symmetry; apply moveL_twistR; symmetry; exact p.
+  Defined.
+
+  Local Definition moveL_fmap01_twistL a b c d e f (g : e $-> _)
+    : fmap01 cat_tensor a (twist b c d) $o f $== g
+      -> f $== fmap01 cat_tensor a (twist c b d) $o g.
+  Proof.
+    intros p.
+    apply (cate_monic_equiv (emap01 cat_tensor a (twiste b c d))).
+    refine (_ $@ cat_assoc _ _ _).
+    refine (_ $@ (_ $@R _)).
+    2: { refine (_ $@ (_^$ $@R _)).
+      2: apply cate_buildequiv_fun.
+      refine ((fmap_id _ _)^$ $@ fmap2 _ _ $@ fmap_comp _ _ _).
+      refine (_^$ $@ (_^$ $@R _)).
+      2: apply cate_buildequiv_fun.
+      apply twist_twist. }
+    refine ((_ $@R _) $@ p $@ (cat_idl _)^$).
+    refine (cate_buildequiv_fun _ $@ fmap02 _ _ _).
+    apply cate_buildequiv_fun.
+  Defined.
+
+  Local Definition moveL_fmap01_twistR a b c d e f (g : _ $-> e)
+    : f $o fmap01 cat_tensor a (twist b c d) $== g
+      -> f $== g $o fmap01 cat_tensor a (twist c b d).
+  Proof.
+    intros p.
+    apply (cate_epic_equiv (emap01 cat_tensor a (twiste b c d))).
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ (_ $@L _)).
+    2: { refine (_^$ $@ (_ $@L _^$)).
+      2: apply cate_buildequiv_fun.
+      refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _).
+      refine ((_ $@L _) $@ _).
+      1: apply cate_buildequiv_fun.
+      apply twist_twist. }
+    refine ((_ $@L _) $@ p $@ (cat_idr _)^$).
+    refine (cate_buildequiv_fun _ $@ fmap02 _ _ _).
+    apply cate_buildequiv_fun.
+  Defined.
+
+  Local Definition moveR_fmap01_twistL a b c d e f (g : e $-> _)
+    : f $== fmap01 cat_tensor a (twist c b d) $o g
+      -> fmap01 cat_tensor a (twist b c d) $o f $== g.
+  Proof.
+    intros p; symmetry; apply moveL_fmap01_twistL; symmetry; exact p.
+  Defined.
+
+  Local Definition moveR_fmap01_twistR a b c d e f (g : _ $-> e)
+    : f $== g $o fmap01 cat_tensor a (twist c b d)
+      -> f $o fmap01 cat_tensor a (twist b c d) $== g.
+  Proof.
+    intros p; symmetry; apply moveL_fmap01_twistR; symmetry; exact p.
+  Defined.
+
+  (** *** The associator *)
+
+  (** Using [braide] and [twiste] we can build an associator. *)
+  Local Definition associator_twist' a b c
+    : cat_tensor a (cat_tensor b c) $<~> cat_tensor (cat_tensor a b) c.
+  Proof.
+    (** We can build the associator out of [braide] and [twiste]. *)
+    refine (braide _ _ $oE _).
+    nrefine (twiste _ _ _ $oE _).
+    exact (emap01 cat_tensor a (braide _ _)).
+  Defined.
+
+  (** We would like to be able to unfold [associator_twist'] to the underlying morphisms. We use this lemma to make that process easier. *)
+  Local Definition associator_twist'_unfold a b c
+    : cate_fun (associator_twist' a b c)
+    $== braid c (cat_tensor a b) $o (twist a c b $o fmap01 cat_tensor a (braid b c)).
+  Proof.
+    refine (cate_buildequiv_fun _ $@ (_ $@@ cate_buildequiv_fun _)).
+    nrefine (cate_buildequiv_fun _ $@ (_ $@@ cate_buildequiv_fun _)).
+    refine (cate_buildequiv_fun _ $@ fmap2 _ _).
+    apply cate_buildequiv_fun.
+  Defined.
+
+  (** Now we can use [associator_twist'] and show that it is a natural equivalence in each variable. *)
+  Local Instance associator_twist : Associator cat_tensor.
+  Proof.
+    snrapply Build_Associator.
+    - exact associator_twist'.
+    - snrapply Build_Is1Natural.
+      simpl; intros [[a b] c] [[a' b'] c'] [[f g] h]; simpl in f, g, h.
+      (** To prove naturality it will be easier to reason about squares. *)
+      change (?w $o ?x $== ?y $o ?z) with (Square z w x y).
+      (** First we remove all the equivalences from the equation. *)
+      nrapply hconcatL.
+      1: apply associator_twist'_unfold.
+      nrapply hconcatR.
+      2: apply associator_twist'_unfold.
+      (** The first square involving [braid] on its own is a naturality square. *)
+      nrapply vconcat.
+      2: rapply braid_nat.
+      (** The second square is just the naturality of twist. *)
+      nrapply vconcat.
+      2: apply twist_nat.
+      nrapply hconcatL.
+      2: nrapply hconcatR.
+      1,3: symmetry; rapply fmap01_is_fmap11.
+      (** Leaving us with a square with a functor application. *)
+      rapply fmap11_square.
+      1: rapply vrefl.
+      (** We are finally left with the naturality of braid. *)
+      apply braid_nat.
+  Defined.
+
+  (** We abbreviate the associator to [α] for the remainder of the section. *)
+  Local Notation α := associator_twist.
+
+  (** *** Unitors *)
+
+  (** Since we assume the [right_unitor] exists, we can derive the [left_unitor] from it together with [braid]. *)
+  Local Instance left_unitor_twist : LeftUnitor cat_tensor cat_tensor_unit.
+  Proof.
+    snrapply Build_NatEquiv'.
+    - snrapply Build_NatTrans.
+      + exact (fun a => right_unitor a $o braid cat_tensor_unit a).
+      + snrapply Build_Is1Natural.
+        intros a b f.
+        change (?w $o ?x $== ?y $o ?z) with (Square z w x y).
+        nrapply vconcat.
+        2: rapply (isnat right_unitor f).
+        rapply braid_nat_r.
+    - intros a.
+      rapply compose_catie'.
+      rapply catie_braid.
+  Defined.
+
+  (** *** Triangle *)
+
+  (** The triangle identity can easily be proven by rearranging the diagram, cancelling and using naturality of [braid]. *)
+  Local Instance triangle_twist : TriangleIdentity cat_tensor cat_tensor_unit.
+  Proof.
+    intros a b.
+    refine (_ $@ (_ $@L _)^$).
+    2: apply associator_twist'_unfold.
+    refine (fmap02 _ a (cate_buildequiv_fun _) $@ _); cbn.
+    refine (fmap01_comp _ _ _ _ $@ _).
+    do 2 refine (_ $@ cat_assoc _ _ _).
+    refine ((twist_unitor _ _ $@ (_ $@R _)) $@R _).
+    apply braid_nat_r.
+  Defined.
+
+  (** *** Pentagon *)
+
+  Local Open Scope long_path_scope.
+
+  Local Instance pentagon_twist : PentagonIdentity cat_tensor.
+  Proof.
+    clear twist_unitor right_unitor cat_tensor_unit.
+    intros a b c d.
+    refine ((_ $@@ _) $@ _ $@ ((fmap02 _ _ _ $@ _)^$ $@@ (_ $@@ (fmap20 _ _ _ $@ _))^$)).
+    1,2,4,6,7: apply associator_twist'_unfold.
+    2: refine (fmap01_comp _ _ _ _ $@ (_ $@L (fmap01_comp _ _ _ _))).
+    2: refine (fmap10_comp _ _ _ _ $@ (_ $@L (fmap10_comp _ _ _ _))).
+    (** We use a notation defined above that shows the base type of the groupoid hom and formats the equation in a way that is easier to read. *)
+    (** Normalize brackets on LHS *)
+    refine (cat_assoc _ _ _ $@ _).
+    refine (_ $@L (cat_assoc _ _ _) $@ _).
+    do 4 refine ((cat_assoc _ _ _)^$ $@ _).
+    (** Normalize brackets on RHS *)
+    refine (_ $@ (((cat_assoc _ _ _) $@R _) $@R _)).
+    do 2 refine (_ $@ ((cat_assoc _ _ _) $@R _)).
+    do 2 refine (_ $@ cat_assoc _ _ _).
+    (** Cancel two braids next to eachother. *)
+    apply moveL_fmap01_fmap01_braidR.
+    apply moveL_fmap01_twistR.
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ ((_ $@L _) $@ cat_idr _)^$).
+    2: refine ((fmap01_comp _ _ _ _)^$ $@ fmap02 _ _ _ $@ fmap01_id _ _ _).
+    2: apply braid_braid.
+    (** *)
+    apply moveL_twistR.
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ (_ $@L _)).
+    2: apply braid_nat_r.
+    refine (_ $@ cat_assoc _ _ _).
+    apply moveL_fmap01_fmap01_braidR.
+    refine (_ $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ (_ $@L _)).
+    2: apply braid_nat_r.
+    refine (_ $@ cat_assoc _ _ _).
+    apply moveL_fmap01_twistR.
+    refine (_ $@ _).
+    2: apply braid_nat_r.
+    (** Putting things back. *)
+    apply moveR_fmap01_twistR.
+    apply moveR_fmap01_fmap01_braidR.
+    apply moveR_twistR.
+    apply moveR_fmap01_twistR.
+    (** There are two braids on the RHS of the LHS that can be swapped. *)
+    refine (cat_assoc _ _ _ $@ _).
+    refine ((_ $@L _) $@ _).
+    1: refine ((fmap01_comp _ _ _ _)^$ $@ fmap02 _ _ _ $@ fmap01_comp _ _ _ _).
+    1: apply braid_nat_r.
+    refine ((cat_assoc _ _ _)^$ $@ _).
+    apply moveR_fmap01_braidR.
+    (** Naturality of twist on the RHS of the LHS. *)
+    refine (cat_assoc _ _ _ $@ _).
+    refine ((_ $@L _) $@ _).
+    1: apply twist_nat_m.
+    refine ((cat_assoc _ _ _)^$ $@ _).
+    (** Moving some things to the RHS so that we can braid and cancel on the LHS. *)
+    apply moveR_twistR.
+    refine (cat_assoc _ _ _ $@ _).
+    refine ((_ $@L _) $@ _).
+    1: apply braid_nat_l.
+    refine ((cat_assoc _ _ _)^$ $@ _).
+    apply moveR_braidR.
+    refine (cat_assoc _ _ _ $@ _).
+    refine ((_ $@L _) $@ cat_idr _ $@ _).
+    1: refine ((fmap01_comp _ _ _ _)^$ $@ fmap02 _ _ _ $@ fmap01_id _ _ _).
+    1: apply braid_braid.
+    apply moveL_braidR.
+    apply moveL_twistR.
+    apply moveL_fmap01_braidR.
+    (** We are almost at the desired 9-gon. Now we cancel the inner braid on the LHS. *)
+    do 4 refine (_ $@ (cat_assoc _ _ _)^$).
+    do 3 refine (cat_assoc _ _ _ $@ _).
+    refine (_ $@L _).
+    apply moveR_twistL.
+    do 4 refine (_ $@ cat_assoc _ _ _).
+    refine ((cat_assoc _ _ _)^$ $@ _).
+    (** Now we move terms around in order to get a homotopy in [a ⊗ (b ⊗ (d ⊗ c)) $-> d ⊗ (c ⊗ (a ⊗ b))]. *)
+    apply moveL_fmap01_twistR.
+    apply moveL_twistR.
+    do 2 refine (_ $@ (cat_assoc _ _ _)^$).
+    do 3 refine (cat_assoc _ _ _ $@ _).
+    apply moveL_twistL.
+    refine (_ $@ cat_assoc _ _ _).
+    do 4 refine ((cat_assoc _ _ _)^$ $@ _).
+    apply moveR_twistR.
+    apply moveR_fmap01_twistR.
+    do 3 refine (_ $@ (cat_assoc _ _ _)^$).
+    do 2 refine (cat_assoc _ _ _ $@ _).
+    apply moveL_fmap01_braidL.
+    do 2 refine (_ $@ cat_assoc _ _ _).
+    do 3 refine ((cat_assoc _ _ _)^$ $@ _).
+    (** And finally, this is the 9-gon we asked for. *)
+    apply twist_9_gon.
+  Defined.
+
+  Local Close Scope long_path_scope.
+
+  (** *** Hexagon *)
+
+  Local Instance hexagon_twist : HexagonIdentity cat_tensor.
+  Proof.
+    intros a b c; simpl.
+    refine (((_ $@L _) $@R _) $@ _ $@ (_ $@@ (_ $@R _))^$).
+    1,3,4: apply associator_twist'_unfold.
+    do 2 refine (((cat_assoc _ _ _)^$ $@R _) $@ _).
+    refine (cat_assoc _ _ _ $@ (_ $@L _) $@ _).
+    { refine ((fmap_comp _ _ _)^$ $@ fmap2 _ _ $@ fmap_id _ _).
+      apply braid_braid. }
+    refine (cat_idr _ $@ _).
+    refine (_ $@ cat_assoc _ _ _).
+    refine (_ $@ ((cat_assoc _ _ _)^$ $@R _)).
+    refine (_ $@ (((cat_idr _)^$ $@ (_ $@L _^$)) $@R _)).
+    2: apply braid_braid.
+    refine (((braid_nat_r _)^$ $@R _) $@ _).
+    refine (cat_assoc _ _ _ $@ (_ $@L _) $@ (cat_assoc _ _ _)^$).
+    refine (_ $@ cat_assoc _ _ _).
+    apply moveL_fmap01_braidR.
+    apply twist_hexagon.
+  Defined.
+
+  (** *** Conclusion *)
+
+  (** In conclusion, we have proven the following: *)
+
+  (** There is a monoidal structure on [A]. *)
+  Local Instance ismonoidal_twist
+    : IsMonoidal A cat_tensor cat_tensor_unit
+    := {}.
+
+  (** There is a symmetric monoidal category on [A]. *)
+  Local Instance issymmetricmonoidal_twist
+    : IsSymmetricMonoidal A cat_tensor cat_tensor_unit
+    := {}.
+
+  (** TODO: WIP *)
+
+  (** Here is a hexagon involving only twist *)
+  Definition twist_hex' a b c d
+    : fmap01 cat_tensor c (twist a b d)
+      $o twist a c (cat_tensor b d)
+      $o fmap01 cat_tensor a (twist b c d)
+    $== twist b c (cat_tensor a d)
+      $o fmap01 cat_tensor b (twist a c d)
+      $o twist a b (cat_tensor c d).
+  Proof.
+    pose proof (twist_hexagon c a d $@ cat_assoc _ _ _) as p.
+    apply moveR_twistL in p.
+    apply moveR_fmap01_braidL in p.
+    apply (fmap02 cat_tensor b) in p.
+    refine (_ $@ ((_ $@L p) $@R _)); clear p.
+    apply moveL_twistR.
+    apply moveL_twistL.
+    refine (_ $@ (fmap01_comp _ _ _ _)^$).
+    (** TODO simplify *)
+    apply moveR_twistL.
+    refine (_ $@ cat_assoc _ _ _).
+  Abort.
+
+End TwistConstruction.
diff --git a/theories/WildCat/NatTrans.v b/theories/WildCat/NatTrans.v
index 2e155b6aabf..ce2871fa1e6 100644
--- a/theories/WildCat/NatTrans.v
+++ b/theories/WildCat/NatTrans.v
@@ -2,9 +2,15 @@ Require Import Basics.Overture Basics.Tactics.
 Require Import WildCat.Core.
 Require Import WildCat.Equiv.
 Require Import WildCat.Square.
+Require Import WildCat.Opposite.
 
-(** ** Natural transformations *)
+(** * Wild Natural Transformations *)
+
+(** ** Transformations *)
 
+(** *** Definition *)
+
+(** A transformation is simply a family of 1-cells over some base type [A] between the sections of two dependent functions [F] and [G]. In most cases [F] and [G] will be non-dependent functors. *)
 Definition Transformation {A : Type} {B : A -> Type} `{forall x, IsGraph (B x)}
   (F G : forall (x : A), B x)
   := forall (a : A), F a $-> G a.
@@ -14,162 +20,202 @@ Identity Coercion fun_trans : Transformation >-> Funclass.
 
 Notation "F $=> G" := (Transformation F G).
 
-(** A 1-natural transformation is natural up to a 2-cell, so its codomain must be a 1-category. *)
-Class Is1Natural {A B : Type} `{IsGraph A} `{Is1Cat B}
-      (F : A -> B) `{!Is0Functor F} (G : A -> B) `{!Is0Functor G}
-      (alpha : F $=> G) :=
-  isnat : forall a a' (f : a $-> a'),
-     (alpha a') $o (fmap F f) $== (fmap G f) $o (alpha a).
-
-Arguments Is1Natural {A B} {isgraph_A}
-  {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B}
-  F {is0functor_F} G {is0functor_G} alpha : rename.
-Arguments isnat {_ _ _ _ _ _ _ _ _ _ _} alpha {alnat _ _} f : rename.
-
-Record NatTrans {A B : Type} `{IsGraph A} `{Is1Cat B} {F G : A -> B}
-  {ff : Is0Functor F} {fg : Is0Functor G} :=
-{
-  trans_nattrans : F $=> G ;
-  is1natural_nattrans : Is1Natural F G trans_nattrans ;
-}.
-
-Arguments NatTrans {A B} {isgraph_A}
-  {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B}
-  F G {is0functor_F} {is0functor_G} : rename.
-Arguments Build_NatTrans {A B} {isgraph_A}
-  {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B}
-  F G {is0functor_F} {is0functor_G} alpha isnat_alpha: rename.
-
-Global Existing Instance is1natural_nattrans.
-Coercion trans_nattrans : NatTrans >-> Transformation.
-
-Definition issig_NatTrans {A B : Type} `{IsGraph A} `{Is1Cat B} (F G : A -> B)
-  {ff : Is0Functor F} {fg : Is0Functor G}
-  : _ <~> NatTrans F G := ltac:(issig).
-
-(** The transposed natural square *)
-Definition isnat_tr {A B : Type} `{IsGraph A} `{Is1Cat B}
-      {F : A -> B} `{!Is0Functor F} {G : A -> B} `{!Is0Functor G}
-      (alpha : F $=> G) `{!Is1Natural F G alpha}
-      {a a' : A} (f : a $-> a')
-  : (fmap G f) $o (alpha a) $== (alpha a') $o (fmap F f)
-  := (isnat alpha f)^$.
-
-Definition id_transformation {A B : Type} `{Is01Cat B} (F : A -> B)
+(** The identity transformation between a functor and itself is the identity function at the section. *)
+Definition trans_id {A B : Type} `{Is01Cat B} (F : A -> B)
   : F $=> F
   := fun a => Id (F a).
 
-Global Instance is1natural_id {A B : Type} `{IsGraph A} `{Is1Cat B}
-       (F : A -> B) `{!Is0Functor F}
-  : Is1Natural F F (id_transformation F).
-Proof.
-  intros a b f; cbn.
-  refine (cat_idl _ $@ (cat_idr _)^$).
-Defined.
-
-Definition nattrans_id {A B : Type} (F : A -> B)
-  `{IsGraph A, Is1Cat B, !Is0Functor F}
-  : NatTrans F F.
-Proof.
-  nrapply Build_NatTrans.
-  rapply is1natural_id.
-Defined.
-
+(** Transformations can be composed pointwise. *)
 Definition trans_comp {A B : Type} `{Is01Cat B}
            {F G K : A -> B} (gamma : G $=> K) (alpha : F $=> G)
   : F $=> K
   := fun a => gamma a $o alpha a.
 
+(** Transformations can be prewhiskered by a function. This means we precompose both sides of the transformation with a function. *)
 Definition trans_prewhisker {A B : Type} {C : B -> Type} {F G : forall x, C x}
   `{Is01Cat B} `{!forall x, IsGraph (C x)}
   `{!forall x, Is01Cat (C x)} (gamma : F $=> G) (K : A -> B) 
   : F o K $=> G o K
   := gamma o K.
 
+(** Transformations can be postwhiskered by a function. This means we postcompose both sides of the transformation with a function. *)
 Definition trans_postwhisker {A B C : Type} {F G : A -> B}
   (K : B -> C) `{Is01Cat B, Is01Cat C, !Is0Functor K} (gamma : F $=> G)
   : K o F $=> K o G
   := fun a => fmap K (gamma a).
 
+(** A transformation in the opposite category is simply a transformation in the original category with the direction swapped. *)
+Definition trans_op {A} {B} `{Is01Cat B}
+  (F : A -> B) (G : A -> B) (alpha : F $=> G)
+  : Transformation (A:=A^op) (B:=fun _ => B^op) G (F : A^op -> B^op)
+  := alpha.
+
+(** ** Naturality *)
+
+(** A transformation is 1-natural if there exists a 2-cell witnessing the naturality square. The codomain of the transformation must be a wild 1-category. *)
+Class Is1Natural {A B : Type} `{IsGraph A, Is1Cat B}
+  (F : A -> B) `{!Is0Functor F} (G : A -> B) `{!Is0Functor G}
+  (alpha : F $=> G) := Build_Is1Natural' {
+  isnat {a a'} (f : a $-> a') : alpha a' $o fmap F f $== fmap G f $o alpha a;
+  (** We also include the transposed naturality square in the definition so that opposite natural transformations are definitionally involutive. In most cases, this will be constructed to be the inverse of the [isnat] field. *)
+  isnat_tr {a a'} (f : a $-> a') : fmap G f $o alpha a $== alpha a' $o fmap F f;
+}.
+
+Arguments Is1Natural {A B} {isgraph_A}
+  {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B}
+  F {is0functor_F} G {is0functor_G} alpha : rename.
+Arguments isnat {_ _ _ _ _ _ _ _ _ _ _} alpha {alnat _ _} f : rename.
+Arguments isnat_tr {_ _ _ _ _ _ _ _ _ _ _} alpha {alnat _ _} f : rename.
+
+(** We coerce naturality proofs to their naturality square as the [isnat] projection can be unwieldy in certain situations where the transformation is difficult to write down. This allows for the naturality proof to be used directly. *)
+Coercion isnat : Is1Natural >-> Funclass.
+
+Definition Build_Is1Natural {A B : Type} `{IsGraph A} `{Is1Cat B}
+  {F G : A -> B} `{!Is0Functor F, !Is0Functor G} (alpha : F $=> G)
+  (isnat : forall a a' (f : a $-> a'), alpha a' $o fmap F f $== fmap G f $o alpha a)
+  : Is1Natural F G alpha.
+Proof.
+  snrapply Build_Is1Natural'.
+  - exact isnat.
+  - intros a a' f.
+    exact (isnat a a' f)^$.
+Defined.
+
+(** The identity transformation is 1-natural. *)
+Global Instance is1natural_id {A B : Type} `{IsGraph A} `{Is1Cat B}
+  (F : A -> B) `{!Is0Functor F}
+  : Is1Natural F F (trans_id F).
+Proof.
+  snrapply Build_Is1Natural.
+  intros a b f; cbn.
+  refine (cat_idl _ $@ (cat_idr _)^$).
+Defined.
+
+(** The composite of 1-natural transformations is 1-natural. *)
 Global Instance is1natural_comp {A B : Type} `{IsGraph A} `{Is1Cat B}
-       {F G K : A -> B} `{!Is0Functor F} `{!Is0Functor G} `{!Is0Functor K}
-       (gamma : G $=> K) `{!Is1Natural G K gamma}
-       (alpha : F $=> G) `{!Is1Natural F G alpha}
+  {F G K : A -> B} `{!Is0Functor F} `{!Is0Functor G} `{!Is0Functor K}
+  (gamma : G $=> K) `{!Is1Natural G K gamma}
+  (alpha : F $=> G) `{!Is1Natural F G alpha}
   : Is1Natural F K (trans_comp gamma alpha).
 Proof.
+  snrapply Build_Is1Natural.
   intros a b f; unfold trans_comp; cbn.
   refine (cat_assoc _ _ _ $@ (_ $@L isnat alpha f) $@ _).
   refine (cat_assoc_opp _ _ _ $@ (isnat gamma f $@R _) $@ _).
   apply cat_assoc.
 Defined.
 
+(** Prewhiskering a transformation preserves naturality. *)
 Global Instance is1natural_prewhisker {A B C : Type} {F G : B -> C} (K : A -> B)
   `{IsGraph A, Is01Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G, !Is0Functor K}
   (gamma : F $=> G) `{L : !Is1Natural F G gamma}
   : Is1Natural (F o K) (G o K) (trans_prewhisker gamma K).
 Proof.
+  snrapply Build_Is1Natural.
   intros x y f; unfold trans_prewhisker; cbn.
-  exact (L _ _ _).
+  exact (isnat gamma _).
 Defined.
 
+(** Postwhiskering a transformation preserves naturality. *)
 Global Instance is1natural_postwhisker {A B C : Type} {F G : A -> B} (K : B -> C)
- `{IsGraph A, Is1Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G, !Is0Functor K, !Is1Functor K}
+  `{IsGraph A, Is1Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G,
+    !Is0Functor K, !Is1Functor K}
   (gamma : F $=> G) `{L : !Is1Natural F G gamma}
   : Is1Natural (K o F) (K o G) (trans_postwhisker K gamma).
 Proof.
+  snrapply Build_Is1Natural.
   intros x y f; unfold trans_postwhisker; cbn.
   refine (_^$ $@ _ $@ _).
   1,3: rapply fmap_comp.
   rapply fmap2.
-  exact (L _ _ _).
+  exact (isnat gamma _).
 Defined.
 
-Definition nattrans_comp {A B : Type} {F G K : A -> B}
-  `{IsGraph A, Is1Cat B, !Is0Functor F, !Is0Functor G, !Is0Functor K}
-  : NatTrans G K -> NatTrans F G -> NatTrans F K.
+(** Modifying a transformation to something pointwise equal preserves naturality. *)
+Definition is1natural_homotopic {A B : Type} `{Is01Cat A} `{Is1Cat B}
+  {F : A -> B} `{!Is0Functor F} {G : A -> B} `{!Is0Functor G}
+  {alpha : F $=> G} (gamma : F $=> G) `{!Is1Natural F G gamma}
+  (p : forall a, alpha a $== gamma a)
+  : Is1Natural F G alpha.
 Proof.
-  intros alpha beta.
-  nrapply Build_NatTrans.
-  rapply (is1natural_comp alpha beta).
+  snrapply Build_Is1Natural.
+  intros a b f.
+  exact ((p b $@R _) $@ isnat gamma f $@ (_ $@L (p a)^$)).
 Defined.
 
+(** The opposite of a natural transformation is natural. *)
+Global Instance is1natural_op A B `{Is01Cat A} `{Is1Cat B}
+  (F : A -> B) `{!Is0Functor F} (G : A -> B) `{!Is0Functor G}
+  (alpha : F $=> G) `{!Is1Natural F G alpha}
+  : Is1Natural (G : A^op -> B^op) (F : A^op -> B^op) (trans_op F G alpha).
+Proof.
+  unfold op.
+  snrapply Build_Is1Natural'.
+  - intros a b.
+    exact (isnat_tr alpha).
+  - intros a b.
+    exact (isnat alpha).
+Defined.
+
+(** ** Natural transformations *)
+
+(** Here we give the bundled definition of a natural transformation which can be more convenient to work with in certain situations. It forms the Hom type of the functor category. *)
+
+Record NatTrans {A B : Type} `{IsGraph A} `{Is1Cat B} {F G : A -> B}
+  {ff : Is0Functor F} {fg : Is0Functor G} := {
+  #[reversible=no]
+  trans_nattrans :> F $=> G;
+  is1natural_nattrans : Is1Natural F G trans_nattrans;
+}.
+
+Arguments NatTrans {A B} {isgraph_A}
+  {isgraph_B} {is2graph_B} {is01cat_B} {is1cat_B}
+  F G {is0functor_F} {is0functor_G} : rename.
+Arguments Build_NatTrans {A B isgraph_A isgraph_B is2graph_B is01cat_B is1cat_B
+  F G is0functor_F is0functor_G} alpha isnat_alpha : rename.
+
+Global Existing Instance is1natural_nattrans.
+
+Definition issig_NatTrans {A B : Type} `{IsGraph A} `{Is1Cat B} (F G : A -> B)
+  {ff : Is0Functor F} {fg : Is0Functor G}
+  : _ <~> NatTrans F G := ltac:(issig).
+
+Definition nattrans_id {A B : Type} (F : A -> B)
+  `{IsGraph A, Is1Cat B, !Is0Functor F}
+  : NatTrans F F
+  := Build_NatTrans (trans_id F) _.
+
+Definition nattrans_comp {A B : Type} {F G K : A -> B}
+  `{IsGraph A, Is1Cat B, !Is0Functor F, !Is0Functor G, !Is0Functor K}
+  : NatTrans G K -> NatTrans F G -> NatTrans F K
+  := fun alpha beta => Build_NatTrans (trans_comp alpha beta) _.
+
 Definition nattrans_prewhisker {A B C : Type} {F G : B -> C}
   `{IsGraph A, Is1Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G}
   (alpha : NatTrans F G) (K : A -> B) `{!Is0Functor K} 
-  : NatTrans (F o K) (G o K).
-Proof.
-  nrapply Build_NatTrans.
-  rapply (is1natural_prewhisker K alpha).
-Defined.
+  : NatTrans (F o K) (G o K)
+  := Build_NatTrans (trans_prewhisker alpha K) _.
 
 Definition nattrans_postwhisker {A B C : Type} {F G : A -> B} (K : B -> C)
   `{IsGraph A, Is1Cat B, Is1Cat C, !Is0Functor F, !Is0Functor G,
     !Is0Functor K, !Is1Functor K} 
-  : NatTrans F G -> NatTrans (K o F) (K o G).
-Proof.
-  intros alpha.
-  nrapply Build_NatTrans.
-  rapply (is1natural_postwhisker K alpha).
-Defined.
+  : NatTrans F G -> NatTrans (K o F) (K o G)
+  := fun alpha => Build_NatTrans (trans_postwhisker K alpha) _.
 
-(** Modifying a transformation to something pointwise equal preserves naturality. *)
-Definition is1natural_homotopic {A B : Type} `{Is01Cat A} `{Is1Cat B}
-      {F : A -> B} `{!Is0Functor F} {G : A -> B} `{!Is0Functor G}
-      {alpha : F $=> G} (gamma : F $=> G) `{!Is1Natural F G gamma}
-      (p : forall a, alpha a $== gamma a)
-  : Is1Natural F G alpha.
-Proof.
-  intros a b f.
-  exact ((p b $@R _) $@ isnat gamma f $@ (_ $@L (p a)^$)).
-Defined.
+Definition nattrans_op {A B : Type} `{Is01Cat A} `{Is1Cat B}
+  {F G : A -> B} `{!Is0Functor F, !Is0Functor G}
+  : NatTrans F G
+    -> NatTrans (A:=A^op) (B:=B^op) (G : A^op -> B^op) (F : A^op -> B^op)
+  := fun alpha => Build_NatTrans (trans_op F G alpha) _.
 
-(** Natural equivalences *)
+(** ** Natural equivalences *)
 
+(** Natural equivalences are families of equivalences that are natural. *)
 Record NatEquiv {A B : Type} `{IsGraph A} `{HasEquivs B}
-  {F G : A -> B} `{!Is0Functor F, !Is0Functor G} :=
-{
-  cat_equiv_natequiv : forall a, F a $<~> G a ;
-  is1natural_natequiv : Is1Natural F G (fun a => cat_equiv_natequiv a) ;
+  {F G : A -> B} `{!Is0Functor F, !Is0Functor G} := {
+  #[reversible=no]
+  cat_equiv_natequiv :> forall a, F a $<~> G a ;
+  is1natural_natequiv :: Is1Natural F G (fun a => cat_equiv_natequiv a) ;
 }.
 
 Arguments NatEquiv {A B} {isgraph_A}
@@ -183,9 +229,7 @@ Definition issig_NatEquiv {A B : Type} `{IsGraph A} `{HasEquivs B}
   (F G : A -> B) `{!Is0Functor F, !Is0Functor G}
   : _ <~> NatEquiv F G := ltac:(issig).
 
-Global Existing Instance is1natural_natequiv.
-Coercion cat_equiv_natequiv : NatEquiv >-> Funclass.
-
+(** From a given natural equivalence, we can get the underlying natural transformation. *)
 Lemma nattrans_natequiv {A B : Type} `{IsGraph A} `{HasEquivs B}
   {F G : A -> B} `{!Is0Functor F, !Is0Functor G}
   : NatEquiv F G -> NatTrans F G.
@@ -199,12 +243,13 @@ Defined.
 Global Set Warnings "-ambiguous-paths".
 Coercion nattrans_natequiv : NatEquiv >-> NatTrans.
 
-(** The above coercion doesn't trigger when it should, so we add the following. *)
+(** The above coercion sometimes doesn't trigger when it should, so we add the following. *)
 Definition isnat_natequiv {A B : Type} `{IsGraph A} `{HasEquivs B}
   {F G : A -> B} `{!Is0Functor F, !Is0Functor G} (alpha : NatEquiv F G)
   {a a' : A} (f : a $-> a')
   := isnat (nattrans_natequiv alpha) f.
 
+(** Often we wish to build a natural equivalence from a natural transformation and a pointwise proof that it is an equivalence. *)
 Definition Build_NatEquiv' {A B : Type} `{IsGraph A} `{HasEquivs B}
   {F G : A -> B} `{!Is0Functor F, !Is0Functor G}
   (alpha : NatTrans F G) `{forall a, CatIsEquiv (alpha a)}
@@ -213,11 +258,20 @@ Proof.
   snrapply Build_NatEquiv.
   - intro a.
     refine (Build_CatEquiv (alpha a)).
-  - intros a a' f.
-    refine (cate_buildequiv_fun _ $@R _ $@ _ $@ (_ $@L cate_buildequiv_fun _)^$).
-    apply (isnat alpha).
+  - snrapply Build_Is1Natural'.
+    + intros a a' f.
+      refine ((cate_buildequiv_fun _ $@R _) $@ _ $@ (_ $@L cate_buildequiv_fun _)^$).
+      apply (isnat alpha).
+    + intros a a' f.
+      refine ((_ $@L cate_buildequiv_fun _) $@ _ $@ (cate_buildequiv_fun _ $@R _)^$).
+      apply (isnat_tr alpha).
 Defined.
 
+Definition natequiv_id {A B : Type} `{IsGraph A} `{HasEquivs B}
+  {F : A -> B} `{!Is0Functor F}
+  : NatEquiv F F
+  := Build_NatEquiv' (nattrans_id F).
+
 Definition natequiv_compose {A B} {F G H : A -> B} `{IsGraph A} `{HasEquivs B}
   `{!Is0Functor F, !Is0Functor G, !Is0Functor H}
   (alpha : NatEquiv G H) (beta : NatEquiv F G)
@@ -240,43 +294,59 @@ Proof.
   all: exact _.
 Defined.
 
+Lemma natequiv_op {A B : Type} `{Is01Cat A} `{HasEquivs B}
+  {F G : A -> B} `{!Is0Functor F, !Is0Functor G}
+  : NatEquiv F G -> NatEquiv (G : A^op -> B^op) F.
+Proof.
+  intros [a n].
+  snrapply Build_NatEquiv.
+  1: exact a.
+  by rapply is1natural_op.
+Defined.
+
+(** We can form the inverse natural equivalence by inverting each map in the family. The naturality proof follows from standard lemmas about inverses. *)
 Definition natequiv_inverse {A B : Type} `{IsGraph A} `{HasEquivs B}
   {F G : A -> B} `{!Is0Functor F, !Is0Functor G}
   : NatEquiv F G -> NatEquiv G F.
 Proof.
   intros [alpha I].
   snrapply Build_NatEquiv.
-  1: intro a; symmetry; apply alpha.
-  intros X Y f.
-  apply vinverse, I.
+  1: exact (fun a => (alpha a)^-1$).
+  snrapply Build_Is1Natural'.
+  + intros X Y f.
+    apply vinverse, I.
+  + intros X Y f.
+    apply hinverse, I.
 Defined.
 
 (** This lemma might seem unnecessery since as functions ((F o G) o K) and (F o (G o K)) are definitionally equal. But the functor instances of both sides are different. This can be a nasty trap since you cannot see this difference clearly. *)
 Definition natequiv_functor_assoc_ff_f {A B C D : Type}
-  `{IsGraph A, HasEquivs B, HasEquivs C, HasEquivs D} (** These are a lot of instances... *)
-  (F : C -> D) (G : B -> C) (K : A -> B) `{!Is0Functor F, !Is0Functor G, !Is0Functor K}
+  `{IsGraph A, HasEquivs B, HasEquivs C, HasEquivs D} 
+  (F : C -> D) (G : B -> C) (K : A -> B)
+  `{!Is0Functor F, !Is0Functor G, !Is0Functor K}
   : NatEquiv ((F o G) o K) (F o (G o K)).
 Proof.
   snrapply Build_NatEquiv.
   1: intro; reflexivity.
+  snrapply Build_Is1Natural.
   intros X Y f.
   refine (cat_prewhisker (id_cate_fun _) _ $@ cat_idl _ $@ _^$).
   refine (cat_postwhisker _ (id_cate_fun _) $@ cat_idr _).
 Defined.
 
-(** *** Pointed natural transformations *)
+(** ** Pointed natural transformations *)
 
 Definition PointedTransformation {B C : Type} `{Is1Cat B, Is1Gpd C}
-           `{IsPointed B, IsPointed C} (F G : B -->* C)
+  `{IsPointed B, IsPointed C} (F G : B -->* C)
   := {eta : F $=> G & eta (point _) $== bp_pointed F $@ (bp_pointed G)^$}.
 
 Notation "F $=>* G" := (PointedTransformation F G) (at level 70).
 
 Definition ptransformation_inverse {B C : Type} `{Is1Cat B, Is1Gpd C}
-           `{IsPointed B, IsPointed C} (F G : B -->* C)
+  `{IsPointed B, IsPointed C} (F G : B -->* C)
   : (F $=>* G) -> (G $=>* F).
 Proof.
-  intros [h p].
+intros [h p].
   exists (fun x => (h x)^$).
   refine (gpd_rev2 p $@ _).
   refine (gpd_rev_pp _ _ $@ _).
@@ -287,7 +357,7 @@ Defined.
 Notation "h ^*$" := (ptransformation_inverse _ _ h) (at level 5).
 
 Definition ptransformation_compose {B C : Type} `{Is1Cat B, Is1Gpd C}
-           `{IsPointed B, IsPointed C} {F0 F1 F2 : B -->* C}
+  `{IsPointed B, IsPointed C} {F0 F1 F2 : B -->* C}
   : (F0 $=>* F1) -> (F1 $=>* F2) -> (F0 $=>* F2).
 Proof.
   intros [h0 p0] [h1 p1].
diff --git a/theories/WildCat/Opposite.v b/theories/WildCat/Opposite.v
index 34d8fcbb80b..8d26289d5bf 100644
--- a/theories/WildCat/Opposite.v
+++ b/theories/WildCat/Opposite.v
@@ -2,9 +2,6 @@
 
 Require Import Basics.Overture Basics.Tactics.
 Require Import WildCat.Core.
-Require Import WildCat.Equiv.
-Require Import WildCat.NatTrans.
-Require Import WildCat.FunctorCat.
 
 (** ** Opposite categories *)
 
@@ -52,6 +49,7 @@ Proof.
     cbn in *.
     exact (h $@L p).
   - intros a b c d f g h; exact (cat_assoc_opp h g f).
+  - intros a b c d f g h; exact (cat_assoc h g f).
   - intros a b f; exact (cat_idr f).
   - intros a b f; exact (cat_idl f).
 Defined.
@@ -59,11 +57,14 @@ Defined.
 Global Instance is1cat_strong_op A `{Is1Cat_Strong A}
   : Is1Cat_Strong (A ^op).
 Proof.
-  srapply Build_Is1Cat_Strong; unfold op in *; cbn in *.
+  snrapply Build_Is1Cat_Strong.
+  1-4: exact _.
+  all: cbn.
   - intros a b c d f g h; exact (cat_assoc_opp_strong h g f).
+  - intros a b c d f g h; exact (cat_assoc_strong h g f).
   - intros a b f.
     apply cat_idr_strong.
-  - intros a b f. 
+  - intros a b f.
     apply cat_idl_strong.
 Defined.
 
@@ -100,7 +101,7 @@ Global Instance is1functor_op A B (F : A -> B)
   `{Is1Cat A, Is1Cat B, !Is0Functor F, !Is1Functor F}
   : Is1Functor (F : A^op -> B^op).
 Proof.
-  apply Build_Is1Functor; unfold op in *; cbn in *.
+  apply Build_Is1Functor; cbn.
   - intros a b; rapply fmap2.
   - exact (fmap_id F).
   - intros a b c f g; exact (fmap_comp F g f).
@@ -112,74 +113,11 @@ Global Instance is0functor_op' A B (F : A^op -> B^op)
   : Is0Functor (F : A -> B)
   := is0functor_op A^op B^op F.
 
-(** [Is1Cat] structures are not definitionally involutive, so we prove the reverse direction separately. *)
+(** [Is1Cat] structures are also definitionally involutive. *)
 Global Instance is1functor_op' A B (F : A^op -> B^op)
   `{Is1Cat A, Is1Cat B, !Is0Functor (F : A^op -> B^op), Fop2 : !Is1Functor (F : A^op -> B^op)}
-  : Is1Functor (F : A -> B).
-Proof.
-  apply Build_Is1Functor; unfold op in *; cbn.
-  - intros a b; exact (@fmap2 A^op B^op _ _ _ _ _ _ _ _ F _ Fop2 b a).
-  - exact (@fmap_id A^op B^op _ _ _ _ _ _ _ _ F _ Fop2).
-  - intros a b c f g; exact (@fmap_comp A^op B^op _ _ _ _ _ _ _ _ F _ Fop2 _ _ _ g f).
-Defined.
-
-(** Bundled opposite functors *)
-Definition fun01_op (A B : Type) `{IsGraph A} `{IsGraph B}
-  : Fun01 A B -> Fun01 A^op B^op.
-Proof.
-  intros F.
-  rapply (Build_Fun01 A^op B^op F).
-Defined.
-
-(** Opposite natural transformations *)
-
-Definition transformation_op {A} {B} `{Is01Cat B}
-           (F : A -> B) (G : A -> B) (alpha : F $=> G)
-  : @Transformation A^op (fun _ => B^op) _
-                     (G : A^op -> B^op) (F : A^op -> B^op).
-Proof.
-  unfold op in *.
-  cbn in *.
-  intro a.
-  apply (alpha a).
-Defined.
-
-Global Instance is1nat_op A B `{Is01Cat A} `{Is1Cat B}
-       (F : A -> B) `{!Is0Functor F}
-       (G : A -> B) `{!Is0Functor G}
-       (alpha : F $=> G) `{!Is1Natural F G alpha}
-  : Is1Natural (G : A^op -> B^op) (F : A^op -> B^op) (transformation_op F G alpha).
-Proof.
-  unfold op in *.
-  unfold transformation_op.
-  cbn.
-  intros a b f.
-  srapply isnat_tr.
-Defined.
-
-(** Opposite categories preserve having equivalences. *)
-Global Instance hasequivs_op {A} `{HasEquivs A} : HasEquivs A^op.
-Proof.
-  srapply Build_HasEquivs; intros a b; unfold op in *; cbn.
-  - exact (b $<~> a).
-  - apply CatIsEquiv.
-  - apply cate_fun'.
-  - apply cate_isequiv'.
-  - apply cate_buildequiv'.
-  - rapply cate_buildequiv_fun'.
-  - apply cate_inv'.
-  - rapply cate_isretr'.
-  - rapply cate_issect'.
-  - intros f g s t.
-    exact (catie_adjointify f g t s).
-Defined.
-
-Global Instance isequivs_op {A : Type} `{HasEquivs A}
-       {a b : A} (f : a $-> b) {ief : CatIsEquiv f}
-  : @CatIsEquiv A^op _ _ _ _ _ b a f.
-Proof.
-  assumption.
-Defined.
+  : Is1Functor (F : A -> B)
+  := is1functor_op A^op B^op F.
 
 Global Instance hasmorext_op {A : Type} `{H0 : HasMorExt A}
   : HasMorExt A^op.
@@ -189,14 +127,10 @@ Proof.
   refine (@isequiv_Htpy_path _ _ _ _ _ H0 b a f g).
 Defined.
 
-Lemma natequiv_op {A B : Type} `{Is01Cat A} `{HasEquivs B}
-  (F G : A -> B) `{!Is0Functor F, !Is0Functor G}
-  : NatEquiv F G -> NatEquiv (G : A^op -> B^op) F.
-Proof.
-  intros [a n].
-  snrapply Build_NatEquiv.
-  { intro x.
-    exact (a x). }
-  rapply is1nat_op.
-Defined.
+Global Instance isinitial_op_isterminal {A : Type} `{Is1Cat A} (x : A)
+  {t : IsTerminal x} : IsInitial (A := A^op) x
+  := t.
 
+Global Instance isterminal_op_isinitial {A : Type} `{Is1Cat A} (x : A)
+  {i : IsInitial x} : IsTerminal (A := A^op) x
+  := i.
diff --git a/theories/WildCat/Paths.v b/theories/WildCat/Paths.v
index f616ea59e8c..882c5a3fb95 100644
--- a/theories/WildCat/Paths.v
+++ b/theories/WildCat/Paths.v
@@ -1,24 +1,124 @@
-Require Import Basics.Overture.
-Require Import WildCat.Core.
+Require Import Basics.Overture Basics.Tactics Basics.PathGroupoids.
+Require Import WildCat.Core WildCat.TwoOneCat WildCat.NatTrans.
 
 (** * Path groupoids as wild categories *)
 
 (** Not global instances for now *)
-Local Instance isgraph_paths (A : Type) : IsGraph A.
+
+(** These are written so that they can be augmented with an existing wildcat structure. For instance, you may partially define a wildcat and ask for paths for the higher cells. *)
+
+(** Any type is a graph with morphisms given by the identity type. *)
+Definition isgraph_paths (A : Type) : IsGraph A
+  := {| Hom := paths |}.
+
+(** Any graph is a 2-graph with 2-cells given by the identity type. *)
+Definition is2graph_paths (A : Type) `{IsGraph A} : Is2Graph A
+  := fun _ _ => isgraph_paths _.
+
+(** Any 2-graph is a 3-graph with 3-cells given by the identity type. *)
+Definition is3graph_paths (A : Type) `{Is2Graph A} : Is3Graph A
+  := fun _ _ => is2graph_paths _.
+
+(** We assume these as instances for the rest of the file with a low priority. *)
+Local Existing Instances isgraph_paths is2graph_paths is3graph_paths | 10.
+
+(** Any type has composition and identity morphisms given by path concatenation and reflexivity. *)
+Global Instance is01cat_paths (A : Type) : Is01Cat A
+  := {| Id := @idpath _ ; cat_comp := fun _ _ _ x y => concat y x |}.
+
+(** Any type has a 0-groupoid structure with inverse morphisms given by path inversion. *)
+Global Instance is0gpd_paths (A : Type) : Is0Gpd A
+  := {| gpd_rev := @inverse _ |}.
+
+(** Postcomposition is a 0-functor when the 2-cells are paths. *)
+Global Instance is0functor_cat_postcomp_paths (A : Type) `{Is01Cat A}
+  (a b c : A) (g : b $-> c)
+  : Is0Functor (cat_postcomp a g).
+Proof.
+  snrapply Build_Is0Functor.
+  exact (@ap _ _ (cat_postcomp a g)).
+Defined.
+
+(** Precomposition is a 0-functor when the 2-cells are paths. *)
+Global Instance is0functor_cat_precomp_paths (A : Type) `{Is01Cat A}
+  (a b c : A) (f : a $-> b)
+  : Is0Functor (cat_precomp c f).
+Proof.
+  snrapply Build_Is0Functor.
+  exact (@ap _ _ (cat_precomp c f)).
+Defined.
+
+(** Any type is a 1-category with n-morphisms given by paths. *)
+Global Instance is1cat_paths {A : Type} : Is1Cat A.
 Proof.
-  constructor.
-  intros x y; exact (x = y).
+  snrapply Build_Is1Cat.
+  - exact _.
+  - exact _.
+  - exact _.
+  - exact _.
+  - exact (@concat_p_pp A).
+  - exact (@concat_pp_p A).
+  - exact (@concat_p1 A).
+  - exact (@concat_1p A).
 Defined.
 
-Local Instance is01cat_paths (A : Type) : Is01Cat A.
+(** Any type is a 1-groupoid with morphisms given by paths. *)
+Global Instance is1gpd_paths {A : Type} : Is1Gpd A.
 Proof.
-  unshelve econstructor.
-  - intros a; reflexivity.
-  - intros a b c q p; exact (p @ q).
+  snrapply Build_Is1Gpd.
+  - exact (@concat_pV A).
+  - exact (@concat_Vp A).
 Defined.
 
-Local Instance is0gpd_paths (A : Type) : Is0Gpd A.
+(** Any type is a 2-category with higher morphhisms given by paths. *)
+Global Instance is21cat_paths {A : Type} : Is21Cat A.
 Proof.
-  constructor.
-  intros x y p; exact (p^).
+  snrapply Build_Is21Cat.
+  - exact _.
+  - exact _.
+  - intros x y z p.
+    snrapply Build_Is1Functor.
+    + intros a b q r.
+      exact (ap (fun x => whiskerR x _)).
+    + reflexivity.
+    + intros a b c.
+      exact (whiskerR_pp p).
+  - intros x y z p.
+    snrapply Build_Is1Functor.
+    + intros a b q r.
+      exact (ap (whiskerL p)).
+    + reflexivity.
+    + intros a b c.
+      exact (whiskerL_pp p).
+  - intros a b c q r s t h g.
+    exact (concat_whisker q r s t h g)^.
+  - intros a b c d q r.
+    snrapply Build_Is1Natural.
+    intros s t h.
+    apply concat_p_pp_nat_r.
+  - intros a b c d q r.
+    snrapply Build_Is1Natural.
+    intros s t h.
+    apply concat_p_pp_nat_m.
+  - intros a b c d q r.
+    snrapply Build_Is1Natural.
+    intros s t h.
+    apply concat_p_pp_nat_l.
+  - intros a b.
+    snrapply Build_Is1Natural.
+    intros p q h; cbn.
+    apply moveL_Mp.
+    lhs nrapply concat_p_pp.
+    exact (whiskerR_p1 h).
+  - intros a b.
+    snrapply Build_Is1Natural.
+    intros p q h.
+    apply moveL_Mp.
+    lhs rapply concat_p_pp.
+    exact (whiskerL_1p h).
+  - intros a b c d e p q r s.
+    lhs nrapply concat_p_pp.
+    exact (pentagon p q r s).
+  - intros a b c p q.
+    exact (triangulator p q).
 Defined.
diff --git a/theories/WildCat/PointedCat.v b/theories/WildCat/PointedCat.v
index f70f475655c..ce7fecc1e3a 100644
--- a/theories/WildCat/PointedCat.v
+++ b/theories/WildCat/PointedCat.v
@@ -1,5 +1,5 @@
 Require Import Basics.Overture Basics.Tactics.
-Require Import WildCat.Core.
+Require Import WildCat.Core WildCat.Opposite.
 Require Import WildCat.Equiv.
 
 (** A wild category is pointed if the initial and terminal object are the same. *)
@@ -65,7 +65,7 @@ Class IsPointedFunctor {A B : Type} (F : A -> B) `{Is1Functor A B F} :=
 }.
 Global Existing Instances preservesinitial_pfunctor preservesterminal_pfunctor.
 
-(** Here is an alternative construct using preservation of the zero object. This requires more structure on the categories however. *)
+(** Here is an alternative constructor using preservation of the zero object. This requires more structure on the categories however. *)
 Definition Build_IsPointedFunctor' {A B : Type} (F : A -> B)
   `{Is1Cat A, Is1Cat B, !Is0Functor F, !Is1Functor F}
   `{!IsPointedCat A, !IsPointedCat B, !HasEquivs A, !HasEquivs B}
@@ -81,7 +81,6 @@ Proof.
     rapply cate_isinitial.
   + intros x tex.
     rapply isterminal_cate.
-    symmetry.
     refine (p $oE _).
     rapply (emap F _).
     rapply cate_isterminal.
@@ -110,3 +109,11 @@ Proof.
   rapply cat_zero_m.
   rapply pfunctor_zero.
 Defined.
+
+(** Opposite category of a pointed category is also pointed. *)
+Global Instance ispointedcat_op {A : Type} `{IsPointedCat A} : IsPointedCat A^op.
+Proof.
+  snrapply Build_IsPointedCat.
+  1: unfold op; exact zero_object.
+  1,2: exact _.
+Defined.
diff --git a/theories/WildCat/Prod.v b/theories/WildCat/Prod.v
index 93b06f6d5bc..12d04db409d 100644
--- a/theories/WildCat/Prod.v
+++ b/theories/WildCat/Prod.v
@@ -21,16 +21,9 @@ Proof.
     exact (f1 $o f2 , g1 $o g2).
 Defined.
 
-(** To avoid having to define a separate notion of "two-variable functor", we define two-variable functors in uncurried form.  The following definition applies such a two-variable functor, with a currying built in. *)
-Definition fmap11 {A B C : Type} `{IsGraph A} `{IsGraph B} `{IsGraph C}
-  (F : A -> B -> C) {H2 : Is0Functor (uncurry F)}
-  {a1 a2 : A} {b1 b2 : B} (f1 : a1 $-> a2) (f2 : b1 $-> b2)
-  : F a1 b1 $-> F a2 b2
-  := @fmap _ _ _ _ (uncurry F) H2 (a1, b1) (a2, b2) (f1, f2).
-
 Global Instance is0gpd_prod A B `{Is0Gpd A} `{Is0Gpd B}
  : Is0Gpd (A * B).
-Proof. 
+Proof.
   srapply Build_Is0Gpd.
   intros [x1 x2] [y1 y2] [f1 f2].
   cbn in *.
@@ -47,27 +40,29 @@ Defined.
 Global Instance is1cat_prod A B `{Is1Cat A} `{Is1Cat B}
   : Is1Cat (A * B).
 Proof.
-  srapply (Build_Is1Cat).
+  srapply Build_Is1Cat.
   - intros [x1 x2] [y1 y2] [z1 z2] [h1 h2].
-    srapply Build_Is0Functor.  
-    intros [f1 f2] [g1 g2] [p1 p2]; cbn in *. 
+    srapply Build_Is0Functor.
+    intros [f1 f2] [g1 g2] [p1 p2]; cbn in *.
     exact ( h1 $@L p1 , h2 $@L p2 ).
   - intros [x1 x2] [y1 y2] [z1 z2] [h1 h2].
-    srapply Build_Is0Functor.  
-    intros [f1 f2] [g1 g2] [p1 p2]; cbn in *. 
+    srapply Build_Is0Functor.
+    intros [f1 f2] [g1 g2] [p1 p2]; cbn in *.
     exact ( p1 $@R h1 , p2 $@R h2 ).
   - intros [a1 a2] [b1 b2] [c1 c2] [d1 d2] [f1 f2] [g1 g2] [h1 h2].
     cbn in *.
     exact(cat_assoc f1 g1 h1, cat_assoc f2 g2 h2).
+  - intros [a1 a2] [b1 b2] [c1 c2] [d1 d2] [f1 f2] [g1 g2] [h1 h2].
+    cbn in *.
+    exact(cat_assoc_opp f1 g1 h1, cat_assoc_opp f2 g2 h2).
   - intros [a1 a2] [b1 b2] [f1 f2].
     cbn in *.
     exact (cat_idl _, cat_idl _).
   - intros [a1 a2] [b1 b2] [g1 g2].
     cbn in *.
-    exact (cat_idr _, cat_idr _). 
+    exact (cat_idr _, cat_idr _).
 Defined.
 
-
 (** Product categories inherit equivalences *)
 
 Global Instance hasequivs_prod A B `{HasEquivs A} `{HasEquivs B}
@@ -97,27 +92,6 @@ Global Instance isequivs_prod A B `{HasEquivs A} `{HasEquivs B}
        {ef : CatIsEquiv f} {eg : CatIsEquiv g}
   : @CatIsEquiv (A*B) _ _ _ _ _ (a1,b1) (a2,b2) (f,g) := (ef,eg).
 
-(** More coherent two-variable functors. *)
-
-Definition fmap22 {A B C : Type} `{Is1Cat A} `{Is1Cat B} `{Is1Cat C}
-  (F : A -> B -> C) `{!Is0Functor (uncurry F), !Is1Functor (uncurry F)}
-  {a1 a2 : A} {b1 b2 : B} (f1 : a1 $-> a2) (f2 : b1 $-> b2) (g1 : a1 $-> a2) (g2 : b1 $-> b2)
-  (alpha : f1 $== g1) (beta : f2 $== g2)
-  : (fmap11 F f1 f2) $== (fmap11 F g1 g2)
-  := @fmap2 _ _ _ _ _ _ _ _ _ _ (uncurry F) _ _ (a1, b1) (a2, b2) (f1, f2) (g1, g2) (alpha, beta).
-
-Global Instance iemap11 {A B C : Type} `{HasEquivs A} `{HasEquivs B} `{HasEquivs C}
-           (F : A -> B -> C) `{!Is0Functor (uncurry F), !Is1Functor (uncurry F)}
-           {a1 a2 : A} {b1 b2 : B} (f1 : a1 $<~> a2) (f2 : b1 $<~> b2)
-  : CatIsEquiv (fmap11 F f1 f2)
-  := @iemap _ _ _ _ _ _ _ _ _ _ _ _ (uncurry F) _ _ (a1, b1) (a2, b2) (f1, f2).
-
-Definition emap11 {A B C : Type} `{HasEquivs A} `{HasEquivs B} `{HasEquivs C}
-           (F : A -> B -> C) `{!Is0Functor (uncurry F), !Is1Functor (uncurry F)}
-           {a1 a2 : A} {b1 b2 : B} (fe1 : a1 $<~> a2)
-           (fe2 : b1 $<~> b2) : (F a1 b1) $<~> (F a2 b2)
-  := @emap _ _ _ _ _ _ _ _ _ _ _ _ (uncurry F) _ _ (a1, b1) (a2, b2) (fe1, fe2).
-
 (** ** Product functors *)
 
 Global Instance is0functor_prod_functor {A B C D : Type}
@@ -177,3 +151,139 @@ Proof.
   - reflexivity.
 Defined.
 
+(** Inclusions into a product category are functorial. *)
+
+Global Instance is0functor_prod_include10 {A B : Type} `{IsGraph A, Is01Cat B}
+  (b : B)
+  : Is0Functor (fun a : A => (a, b)).
+Proof.
+  nrapply Build_Is0Functor.
+  intros a c f.
+  exact (f, Id b).
+Defined.
+
+Global Instance is1functor_prod_include10 {A B : Type} `{Is1Cat A, Is1Cat B}
+  (b : B)
+  : Is1Functor (fun a : A => (a, b)).
+Proof.
+  nrapply Build_Is1Functor.
+  - intros a c f g p.
+    exact (p, Id _).
+  - intros a; reflexivity.
+  - intros a c d f g.
+    exact (Id _, (cat_idl _)^$).
+Defined.
+
+Global Instance is0functor_prod_include01 {A B : Type} `{Is01Cat A, IsGraph B}
+  (a : A)
+  : Is0Functor (fun b : B => (a, b)).
+Proof.
+  nrapply Build_Is0Functor.
+  intros b c f.
+  exact (Id a, f).
+Defined.
+
+Global Instance is1functor_prod_include01 {A B : Type} `{Is1Cat A, Is1Cat B}
+  (a : A)
+  : Is1Functor (fun b : B => (a, b)).
+Proof.
+  nrapply Build_Is1Functor.
+  - intros b c f g p.
+    exact (Id _, p).
+  - intros b; reflexivity.
+  - intros b c d f g.
+    exact ((cat_idl _)^$, Id _).
+Defined.
+
+(** Functors from a product category are functorial in each argument *)
+
+Global Instance is0functor_functor_uncurried01 {A B C : Type}
+  `{Is01Cat A, IsGraph B, IsGraph C}
+  (F : A * B -> C) `{!Is0Functor F} (a : A)
+  : Is0Functor (fun b => F (a, b))
+  := is0functor_compose (fun b => (a, b)) F.
+
+Global Instance is1functor_functor_uncurried01 {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A * B -> C) `{!Is0Functor F, !Is1Functor F} (a : A)
+  : Is1Functor (fun b => F (a, b))
+  := is1functor_compose (fun b => (a, b)) F.
+
+Global Instance is0functor_functor_uncurried10 {A B C : Type}
+  `{IsGraph A, Is01Cat B, IsGraph C}
+  (F : A * B -> C) `{!Is0Functor F} (b : B)
+  : Is0Functor (fun a => F (a, b))
+  := is0functor_compose (fun a => (a, b)) F.
+
+Global Instance is1functor_functor_uncurried10 {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A * B -> C) `{!Is0Functor F, !Is1Functor F} (b : B)
+  : Is1Functor (fun a => F (a, b))
+  := is1functor_compose (fun a => (a, b)) F.
+
+(** Conversely, if [F : A * B -> C] is a 0-functor in each variable, then it is a 0-functor. *)
+Definition is0functor_prod_is0functor {A B C : Type}
+  `{IsGraph A, IsGraph B, Is01Cat C} (F : A * B -> C)
+  `{!forall a, Is0Functor (fun b => F (a,b)), !forall b, Is0Functor (fun a => F (a,b))}
+  : Is0Functor F.
+Proof.
+  snrapply Build_Is0Functor.
+  intros [a b] [a' b'] [f g].
+  exact (fmap (fun a0 => F (a0,b')) f $o fmap (fun b0 => F (a,b0)) g).
+Defined.
+(** TODO: If we make this an instance, will it cause typeclass search to spin? *)
+Hint Immediate is0functor_prod_is0functor : typeclass_instances.
+
+(** And if [F : A * B -> C] is a 1-functor in each variable and satisfies a coherence, then it is a 1-functor. *)
+Definition is1functor_prod_is1functor {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C} (F : A * B -> C)
+  `{!forall a, Is0Functor (fun b => F (a,b)), !forall b, Is0Functor (fun a => F (a,b))}
+  `{!forall a, Is1Functor (fun b => F (a,b)), !forall b, Is1Functor (fun a => F (a,b))}
+  (bifunctor_coh : forall a0 a1 (f : a0 $-> a1) b0 b1 (g : b0 $-> b1),
+    fmap (fun b => F (a1,b)) g $o fmap (fun a => F (a,b0)) f
+      $== fmap (fun a => F(a,b1)) f $o fmap (fun b => F (a0,b)) g)
+  : Is1Functor F.
+Proof.
+  snrapply Build_Is1Functor.
+  - intros [a b] [a' b'] [f g] [f' g'] [p p']; unfold fst, snd in * |- .
+    exact (fmap2 (fun b0 => F (a,b0)) p' $@@ fmap2 (fun a0 => F (a0,b')) p).
+  - intros [a b].
+    exact ((fmap_id (fun b0 => F (a,b0)) b $@@ fmap_id (fun a0 => F (a0,b)) _) $@ cat_idr _).
+  - intros [a b] [a' b'] [a'' b''] [f g] [f' g']; unfold fst, snd in * |- .
+    refine ((fmap_comp (fun b0 => F (a,b0)) g g' $@@ fmap_comp (fun a0 => F (a0,b'')) f f') $@ _).
+    nrefine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ cat_assoc _ _ _).
+    refine (cat_assoc _ _ _ $@ (_ $@L _^$) $@ cat_assoc_opp _ _ _).
+    nrapply bifunctor_coh.
+Defined.
+Hint Immediate is1functor_prod_is1functor : typeclass_instances.
+
+(** Applies a two variable functor via uncurrying. Note that the precondition on [C] is slightly weaker than that of [Bifunctor.fmap11]. *)
+Definition fmap11_uncurry {A B C : Type} `{IsGraph A, IsGraph B, IsGraph C}
+  (F : A -> B -> C) {H2 : Is0Functor (uncurry F)}
+  {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} (g : b0 $-> b1)
+  : F a0 b0 $-> F a1 b1
+  := @fmap _ _ _ _ (uncurry F) H2 (a0, b0) (a1, b1) (f, g).
+
+Definition fmap_pair {A B C : Type}  
+  `{IsGraph A, IsGraph B, IsGraph C}  
+  (F : A * B -> C) `{!Is0Functor F}  
+  {a0 a1 : A} (f : a0 $-> a1) {b0 b1 : B} (g : b0 $-> b1)  
+  : F (a0, b0) $-> F (a1, b1)  
+  := fmap (a := (a0, b0)) (b := (a1, b1)) F (f, g).  
+
+Definition fmap_pair_comp {A B C : Type}  
+  `{Is1Cat A, Is1Cat B, Is1Cat C}  
+  (F : A * B -> C) `{!Is0Functor F, !Is1Functor F}  
+  {a0 a1 a2 : A} {b0 b1 b2 : B}
+  (f : a0 $-> a1) (h : b0 $-> b1) (g : a1 $-> a2) (i : b1 $-> b2)  
+  : fmap_pair F (g $o f) (i $o h)
+    $== fmap_pair F g i $o fmap_pair F f h
+  := fmap_comp (a := (a0, b0)) (b := (a1, b1)) (c := (a2, b2)) F (f, h) (g, i).
+
+Definition fmap2_pair {A B C : Type}
+  `{Is1Cat A, Is1Cat B, Is1Cat C}
+  (F : A * B -> C) `{!Is0Functor F, !Is1Functor F}
+  {a0 a1 : A} {f f' : a0 $-> a1} (p : f $== f')
+  {b0 b1 : B} {g g' : b0 $-> b1} (q : g $== g')
+  : fmap_pair F f g $== fmap_pair F f' g'
+  := fmap2 F (a := (a0, b0)) (b := (a1, b1)) (f := (f, g)) (g := (f' ,g')) (p, q).
diff --git a/theories/WildCat/Products.v b/theories/WildCat/Products.v
index 3356d57b949..b2719591acf 100644
--- a/theories/WildCat/Products.v
+++ b/theories/WildCat/Products.v
@@ -1,388 +1,1030 @@
-Require Import Basics EquivGpd Types.Prod.
-Require Import WildCat.Core WildCat.ZeroGroupoid WildCat.Equiv WildCat.Yoneda WildCat.Universe WildCat.NatTrans WildCat.Opposite.
+Require Import Basics.Equivalences Basics.Overture Basics.Tactics.
+Require Import Types.Bool Types.Prod Types.Forall.
+Require Import WildCat.Bifunctor WildCat.Core WildCat.Equiv WildCat.EquivGpd
+               WildCat.Forall WildCat.NatTrans WildCat.Opposite
+               WildCat.Universe WildCat.Yoneda WildCat.ZeroGroupoid
+               WildCat.Monoidal.
 
 (** * Categories with products *)
 
-Definition cat_prod_corec_inv {A : Type} `{Is1Cat A}
-  (xy x y z : A) (pr1 : xy $-> x) (pr2 : xy $-> y)
-  : yon_0gpd xy z $-> prod_0gpd (yon_0gpd x z) (yon_0gpd y z).
+Definition cat_prod_corec_inv {I A : Type} `{Is1Cat A}
+  (prod : A) (x : I -> A) (z : A) (pr : forall i, prod $-> x i)
+  : yon_0gpd prod z $-> prod_0gpd I (fun i => yon_0gpd (x i) z).
 Proof.
-  snrapply prod_0gpd_corec; by apply (fmap (fun x => yon_0gpd x z)). 
+  snrapply equiv_prod_0gpd_corec.
+  intros i.
+  exact (fmap (fun x => yon_0gpd x z) (pr i)).
 Defined.
 
-(* A binary product of two objects of a category is an object of the category with a pair of projections such that the induced map is an equivalence. *)
-Class BinaryProduct {A : Type} `{Is1Cat A} {x y : A} := Build_BinaryProduct' {
+(* A product of an [I]-indexed family of objects of a category is an object of the category with an [I]-indexed family of projections such that the induced map is an equivalence. *)
+Class Product (I : Type) {A : Type} `{Is1Cat A} {x : I -> A} := Build_Product' {
   cat_prod : A;
-  cat_pr1 : cat_prod $-> x;
-  cat_pr2 : cat_prod $-> y;
+  cat_pr : forall i : I, cat_prod $-> x i;
   cat_isequiv_cat_prod_corec_inv
-    :: forall z, CatIsEquiv (cat_prod_corec_inv cat_prod x y z cat_pr1 cat_pr2);
+    :: forall z : A, CatIsEquiv (cat_prod_corec_inv cat_prod x z cat_pr);
 }.
 
-Arguments BinaryProduct {A _ _ _ _} x y.
-Arguments cat_prod {A _ _ _ _} x y {_}.
+Arguments Product I {A _ _ _ _} x.
+Arguments cat_prod I {A _ _ _ _} x {product} : rename.
 
-(** This is a convenience wrapper for building BinaryProducts *)
-Definition Build_BinaryProduct {A : Type} `{Is1Cat A} {x y : A}
-  (cat_prod : A) (cat_pr1 : cat_prod $-> x) (cat_pr2 : cat_prod $-> y)
-  (cat_prod_corec : forall z : A, (z $-> x) -> (z $-> y) -> (z $-> cat_prod))
-  (cat_prod_beta_pr1 : forall z (f : z $-> x) (g : z $-> y), cat_pr1 $o cat_prod_corec z f g $== f)
-  (cat_prod_beta_pr2 : forall z (f : z $-> x) (g : z $-> y), cat_pr2 $o cat_prod_corec z f g $== g)
-  (cat_prod_pr_eta : forall z (f g : z $-> cat_prod), cat_pr1 $o f $== cat_pr1 $o g -> cat_pr2 $o f $== cat_pr2 $o g -> f $== g)
-  : BinaryProduct x y.
+(** A convenience wrapper for building products *)
+Definition Build_Product (I : Type) {A : Type} `{Is1Cat A} {x : I -> A}
+  (cat_prod : A) (cat_pr : forall i : I, cat_prod $-> x i)
+  (cat_prod_corec : forall z : A,
+    (forall i : I, z $-> x i) -> (z $-> cat_prod))
+  (cat_prod_beta_pr : forall (z : A) (f : forall i, z $-> x i) (i : I),
+    cat_pr i $o cat_prod_corec z f $== f i)
+  (cat_prod_eta_pr : forall (z : A) (f g : z $-> cat_prod),
+    (forall i : I, cat_pr i $o f $== cat_pr i $o g) -> f $== g)
+  : Product I x.
 Proof.
-  snrapply (Build_BinaryProduct' _ _ _ _ _ _ _ cat_prod cat_pr1 cat_pr2).
+  snrapply (Build_Product' I A _ _ _ _ _ cat_prod cat_pr).
   intros z.
-  apply isequiv_0gpd_issurjinj.
-  snrapply Build_IsSurjInj.
-  - intros [f g].
-    exists (cat_prod_corec z f g).
-    split.
-    + apply cat_prod_beta_pr1.
-    + apply cat_prod_beta_pr2.
-  - intros f g [p q].
-    by apply cat_prod_pr_eta.
+  nrapply isequiv_0gpd_issurjinj.
+  nrapply Build_IsSurjInj.
+  - intros f.
+    exists (cat_prod_corec z f).
+    intros i.
+    nrapply cat_prod_beta_pr.
+  - intros f g p.
+    by nrapply cat_prod_eta_pr.
 Defined.
 
 Section Lemmata.
 
-  Context {A : Type} {x y : A} `{BinaryProduct _ x y}.
+  Context (I : Type) {A : Type} {x : I -> A} `{Product I _ x}.
 
   Definition cate_cat_prod_corec_inv {z : A}
-    : (yon_0gpd (cat_prod x y) z) $<~> prod_0gpd (yon_0gpd x z) (yon_0gpd y z).
-  Proof.
-    srapply Build_CatEquiv.
-  Defined.
+    : (yon_0gpd (cat_prod I x) z) $<~> prod_0gpd I (fun i => yon_0gpd (x i) z)
+    := Build_CatEquiv (cat_prod_corec_inv (cat_prod I x) x z cat_pr).
 
   Definition cate_cat_prod_corec {z : A}
-    : prod_0gpd (yon_0gpd x z) (yon_0gpd y z) $<~> (yon_0gpd (cat_prod x y) z)
+    : prod_0gpd I (fun i => yon_0gpd (x i) z) $<~> (yon_0gpd (cat_prod I x) z)
     := cate_cat_prod_corec_inv^-1$.
 
   Definition cat_prod_corec {z : A}
-    : (z $-> x) -> (z $-> y) -> (z $-> cat_prod x y).
+    : (forall i, z $-> x i) -> (z $-> cat_prod I x).
   Proof.
-    intros f g.
     apply cate_cat_prod_corec.
-    exact (f, g).
   Defined.
 
-  (** Applying the first projection after a map pairing gives the first map. *)
-  Lemma cat_prod_beta_pr1 {z : A} (f : z $-> x) (g : z $-> y)
-    : cat_pr1 $o cat_prod_corec f g $== f.
+  (** Applying the [i]th projection after a tuple of maps gives the [ith] map. *)
+  Lemma cat_prod_beta {z : A} (f : forall i, z $-> x i)
+    : forall i, cat_pr i $o cat_prod_corec f $== f i.
   Proof.
-    exact (fst (cate_isretr cate_cat_prod_corec_inv (f, g))).
-  Defined.
-
-  (** Applying the second projection after a map pairing gives the second map. *)
-  Lemma cat_prod_beta_pr2 {z : A} (f : z $-> x) (g : z $-> y)
-    : cat_pr2 $o cat_prod_corec f g $== g.
-  Proof.
-    exact (snd (cate_isretr cate_cat_prod_corec_inv (f, g))).
+    exact (cate_isretr cate_cat_prod_corec_inv f).
   Defined.
 
   (** The pairing map is the unique map that makes the following diagram commute. *)
-  Lemma cat_prod_eta {z : A} (f : z $-> cat_prod x y)
-    : cat_prod_corec (cat_pr1 $o f) (cat_pr2 $o f) $== f.
+  Lemma cat_prod_eta {z : A} (f : z $-> cat_prod I x)
+    : cat_prod_corec (fun i => cat_pr i $o f) $== f.
   Proof.
     exact (cate_issect cate_cat_prod_corec_inv f).
   Defined.
 
-  (* TODO: decompose and move *)
   Local Instance is0functor_prod_0gpd_helper
-    : Is0Functor (fun z : A^op => prod_0gpd (yon_0gpd x z) (yon_0gpd y z)).
+    : Is0Functor (fun z : A^op => prod_0gpd I (fun i => yon_0gpd (x i) z)).
   Proof.
     snrapply Build_Is0Functor.
     intros a b f.
     snrapply Build_Morphism_0Gpd.
-    - intros [g g'].
-      exact (f $o g, f $o g').
+    - intros g i.
+      exact (f $o g i).
     - snrapply Build_Is0Functor.
-      intros [g g'] [h h'] [p q].
-      split.
-      + exact (f $@L p).
-      + exact (f $@L q).
+      intros g h p i.
+      exact (f $@L p i).
   Defined.
 
-  (* TODO: decompose and move *)
   Local Instance is1functor_prod_0gpd_helper
-    : Is1Functor (fun z : A^op => prod_0gpd (yon_0gpd x z) (yon_0gpd y z)).
+    : Is1Functor (fun z : A^op => prod_0gpd I (fun i => yon_0gpd (x i) z)).
   Proof.
     snrapply Build_Is1Functor.
-    - intros a b f g p [r_fst r_snd].
-      cbn; split.
-      + refine (_ $@L _).
-        apply p.
-      + refine (_ $@L _).
-        apply p.
-    - intros a [r_fst r_snd].
-      split; apply cat_idl.
-    - intros a b c f g [r_fst r_snd].
-      split; apply cat_assoc.
+    - intros a b f g p r i.
+      refine (_ $@L _).
+      exact p.
+    - intros a r i.
+      nrapply cat_idl; exact _.
+    - intros a b c f g r i.
+      nrapply cat_assoc; exact _.
   Defined.
 
   Definition natequiv_cat_prod_corec_inv
-    : NatEquiv (yon_0gpd (cat_prod x y)) (fun z : A^op => prod_0gpd (yon_0gpd x z) (yon_0gpd y z)).
+    : NatEquiv (yon_0gpd (cat_prod I x))
+      (fun z : A^op => prod_0gpd I (fun i => yon_0gpd (x i) z)).
   Proof.
     snrapply Build_NatEquiv.
-    { intros a.
-      apply cate_cat_prod_corec_inv. }
+    1: intro; nrapply cate_cat_prod_corec_inv.
     exact (is1natural_yoneda_0gpd
-      (cat_prod x y)
-      (fun z : A^op => prod_0gpd (yon_0gpd x z) (yon_0gpd y z))
-      (cat_pr1, cat_pr2)).
+      (cat_prod I x)
+      (fun z => prod_0gpd I (fun i => yon_0gpd (x i) z))
+      cat_pr).
   Defined.
 
-  Lemma cat_prod_corec_eta {z : A} {f f' : z $-> x} {g g' : z $-> y}
-    : f $== f' -> g $== g' -> cat_prod_corec f g $== cat_prod_corec f' g'.
+  Lemma cat_prod_corec_eta {z : A} {f f' : forall i, z $-> x i}
+    : (forall i, f i $== f' i) -> cat_prod_corec f $== cat_prod_corec f'.
   Proof.
-    intros p q.
+    intros p.
     unfold cat_prod_corec.
-    apply (moveL_equiv_V_0gpd cate_cat_prod_corec_inv).
-    refine (cate_isretr cate_cat_prod_corec_inv _ $@ _).
-    split.
-    - exact p.
-    - exact q.
+    nrapply (moveL_equiv_V_0gpd cate_cat_prod_corec_inv).
+    nrefine (cate_isretr cate_cat_prod_corec_inv _ $@ _).
+    exact p.
   Defined.
 
-  Lemma cat_prod_pr_eta {z : A} {f f' : z $-> cat_prod x y}
-    : cat_pr1 $o f $== cat_pr1 $o f' -> cat_pr2 $o f $== cat_pr2 $o f' -> f $== f'.
+  Lemma cat_prod_pr_eta {z : A} {f f' : z $-> cat_prod I x}
+    : (forall i, cat_pr i $o f $== cat_pr i $o f') -> f $== f'.
   Proof.
-    intros fst snd.
+    intros p.
     refine ((cat_prod_eta _)^$ $@ _ $@ cat_prod_eta _).
-    by apply cat_prod_corec_eta.
+    by nrapply cat_prod_corec_eta.
   Defined.
 
 End Lemmata.
 
 (** *** Diagonal map *)
 
-Definition cat_prod_diag {A : Type} `{Is1Cat A} (x : A) `{!BinaryProduct x x}
-  : x $-> cat_prod x x
-  := cat_prod_corec (Id _) (Id _).
+Definition cat_prod_diag {I : Type} {A : Type} (x : A)
+  `{Product I _ (fun _ => x)}
+  : x $-> cat_prod I (fun _ => x)
+  := cat_prod_corec I (fun _ => Id x).
+
+(** *** Uniqueness of products *)
+
+Definition cate_cat_prod {I J : Type} (ie : I <~> J) {A : Type} `{HasEquivs A}
+  (x : I -> A) `{!Product I x} (y : J -> A) `{!Product J y}
+  (e : forall i : I, x i $<~> y (ie i))
+  : cat_prod I x $<~> cat_prod J y.
+Proof.
+  nrapply yon_equiv_0gpd.
+  nrefine (natequiv_compose _ (natequiv_cat_prod_corec_inv _)).
+  nrefine (natequiv_compose
+            (natequiv_inverse (natequiv_cat_prod_corec_inv _)) _).
+  snrapply Build_NatEquiv.
+  - intros z.
+    nrapply (cate_prod_0gpd ie).
+    intros i.
+    exact (natequiv_yon_equiv_0gpd (e i) _).
+  - snrapply Build_Is1Natural.
+    intros a b f g j.
+    cbn.
+    destruct (eisretr ie j).
+    exact (cat_assoc_opp _ _ _).
+Defined.
+
+(** [I]-indexed products are unique no matter how they are constructed. *)
+Definition cat_prod_unique {I A : Type} `{HasEquivs A}
+  (x : I -> A) `{!Product I x} (y : I -> A) `{!Product I y}
+  (e : forall i : I, x i $<~> y i)
+  : cat_prod I x $<~> cat_prod I y.
+Proof.
+  exact (cate_cat_prod 1 x y e).
+Defined.
+
+(** *** Existence of products *)
+
+Class HasProducts (I A : Type) `{Is1Cat A}
+  := has_products :: forall x : I -> A, Product I x.
+
+Class HasAllProducts (A : Type) `{Is1Cat A}
+  := has_all_products :: forall I : Type, HasProducts I A.
+
+(** *** Product functor *)
+
+Global Instance is0functor_cat_prod (I : Type) (A : Type) `{HasProducts I A}
+  : Is0Functor (fun x : I -> A => cat_prod I x).
+Proof.
+  nrapply Build_Is0Functor.
+  intros x y f.
+  exact (cat_prod_corec I (fun i => f i $o cat_pr i)).
+Defined.
+
+Global Instance is1functor_cat_prod (I : Type) (A : Type) `{HasProducts I A}
+  : Is1Functor (fun x : I -> A => cat_prod I x).
+Proof.
+  nrapply Build_Is1Functor.
+  - intros x y f g p.
+    exact (cat_prod_corec_eta I (fun i => p i $@R cat_pr i)).
+  - intros x.
+    nrefine (_ $@ (cat_prod_eta I (Id _))).
+    exact (cat_prod_corec_eta I (fun i => cat_idl _ $@ (cat_idr _)^$)).
+  - intros x y z f g.
+    nrapply cat_prod_pr_eta.
+    intros i.
+    nrefine (cat_prod_beta _ _ _ $@ _).
+    nrefine (_ $@ cat_assoc _ _ _).
+    symmetry.
+    nrefine (cat_prod_beta _ _ _ $@R _ $@ _).
+    nrefine (cat_assoc _ _ _ $@ _).
+    nrefine (_ $@L cat_prod_beta _ _ _ $@ _).
+    nrapply cat_assoc_opp.
+Defined.
+
+(** *** Categories with specific kinds of products *)
 
-(** *** Categories with binary products *)
+Definition isterminal_prodempty {A : Type} {z : A}
+  `{Product Empty A (fun _ => z)}
+  : IsTerminal (cat_prod Empty (fun _ => z)).
+Proof.
+  intros a.
+  snrefine (cat_prod_corec _ _; fun f => cat_prod_pr_eta _ _); intros [].
+Defined.
+
+(** *** Binary products *)
+
+Class BinaryProduct {A : Type} `{Is1Cat A} (x y : A)
+  := binary_product :: Product Bool (fun b => if b then x else y).
 
 (** A category with binary products is a category with a binary product for each pair of objects. *)
-Class HasBinaryProducts (A : Type) `{Is1Cat A} :=
-  binary_products :: forall x y : A, BinaryProduct x y
-.
+Class HasBinaryProducts (A : Type) `{Is1Cat A}
+  := has_binary_products :: forall x y : A, BinaryProduct x y.
 
-(** *** Symmetry of products *)
+Global Instance hasbinaryproducts_hasproductsbool {A : Type} `{HasProducts Bool A}
+  : HasBinaryProducts A
+  := fun x y => has_products (fun b : Bool => if b then x else y).
 
-Section Symmetry.
+Section BinaryProducts.
 
-  (** The requirement of having all binary products can be weakened further to having specific binary products, but it is not clear this is a useful generality. *)
-  Context {A : Type} `{HasEquivs A} `{!HasBinaryProducts A}.
+  Context {A : Type} `{Is1Cat A} {x y : A} `{!BinaryProduct x y}.
+
+  Definition cat_binprod : A
+    := cat_prod Bool (fun b : Bool => if b then x else y).
+
+  Definition cat_pr1 : cat_binprod $-> x := cat_pr true.
 
-  Definition cat_prod_swap (x y : A) : cat_prod x y $-> cat_prod y x
-    := cat_prod_corec cat_pr2 cat_pr1.
+  Definition cat_pr2 : cat_binprod $-> y := cat_pr false.
 
-  Lemma cat_prod_swap_cat_prod_swap (x y : A)
-    : cat_prod_swap x y $o cat_prod_swap y x $== Id _.
+  Definition cat_binprod_corec {z : A} (f : z $-> x) (g : z $-> y)
+    : z $-> cat_binprod.
   Proof.
-    unfold cat_prod_swap.
-    apply cat_prod_pr_eta.
-    - refine ((cat_assoc _ _ _)^$ $@ _).
-      refine (cat_prod_beta_pr1 _ _ $@R _ $@ _).
-      refine (cat_prod_beta_pr2 _ _ $@ _).
-      exact (cat_idr _)^$.
-    - refine ((cat_assoc _ _ _)^$ $@ _).
-      refine (cat_prod_beta_pr2 _ _ $@R _ $@ _).
-      refine (cat_prod_beta_pr1 _ _ $@ _).
-      exact (cat_idr _)^$.
+    nrapply (cat_prod_corec Bool).
+    intros [|].
+    - exact f.
+    - exact g.
   Defined.
 
-  Lemma cate_prod_swap (x y : A)
-    : cat_prod x y $<~> cat_prod y x.
+  Definition cat_binprod_beta_pr1 {z : A} (f : z $-> x) (g : z $-> y)
+    : cat_pr1 $o cat_binprod_corec f g $== f
+    := cat_prod_beta _ _ true.
+
+  Definition cat_binprod_beta_pr2 {z : A} (f : z $-> x) (g : z $-> y)
+    : cat_pr2 $o cat_binprod_corec f g $== g
+    := cat_prod_beta _ _ false.
+
+  Definition cat_binprod_eta {z : A} (f : z $-> cat_binprod)
+    : cat_binprod_corec (cat_pr1 $o f) (cat_pr2 $o f) $== f.
   Proof.
-    snrapply cate_adjointify.
-    1,2: apply cat_prod_swap.
-    all: apply cat_prod_swap_cat_prod_swap.
+    unfold cat_binprod_corec.
+    nrapply cat_prod_pr_eta.
+    intros [|].
+    - exact (cat_binprod_beta_pr1 _ _).
+    - exact (cat_binprod_beta_pr2 _ _).
   Defined.
 
-End Symmetry.
+  Definition cat_binprod_eta_pr {z : A} (f g : z $-> cat_binprod)
+    : cat_pr1 $o f $== cat_pr1 $o g -> cat_pr2 $o f $== cat_pr2 $o g -> f $== g.
+  Proof.
+    intros p q.
+    rapply cat_prod_pr_eta.
+    intros [|].
+    - exact p.
+    - exact q.
+  Defined.
 
-(** *** Product functor *)
+  Definition cat_binprod_corec_eta {z : A} (f f' : z $-> x) (g g' : z $-> y)
+    : f $== f' -> g $== g' -> cat_binprod_corec f g $== cat_binprod_corec f' g'.
+  Proof.
+    intros p q.
+    rapply cat_prod_corec_eta.
+    intros [|].
+    - exact p.
+    - exact q.
+  Defined.
 
-(** Binary products are functorial in each argument. *)
+End BinaryProducts.
 
-Global Instance is0functor_cat_prod_l {A : Type}
-  `{HasBinaryProducts A} y
-  : Is0Functor (fun x => cat_prod x y).
+Arguments cat_binprod {A _ _ _ _} x y {_}.
+
+(** A convenience wrapper for building binary products *)
+Definition Build_BinaryProduct {A : Type} `{Is1Cat A} {x y : A}
+  (cat_binprod : A) (cat_pr1 : cat_binprod $-> x) (cat_pr2 : cat_binprod $-> y)
+  (cat_binprod_corec : forall z : A, z $-> x -> z $-> y -> z $-> cat_binprod)
+  (cat_binprod_beta_pr1 : forall (z : A) (f : z $-> x) (g : z $-> y),
+    cat_pr1 $o cat_binprod_corec z f g $== f)
+  (cat_binprod_beta_pr2 : forall (z : A) (f : z $-> x) (g : z $-> y),
+    cat_pr2 $o cat_binprod_corec z f g $== g)
+  (cat_binprod_eta_pr : forall (z : A) (f g : z $-> cat_binprod),
+    cat_pr1 $o f $== cat_pr1 $o g -> cat_pr2 $o f $== cat_pr2 $o g -> f $== g)
+  : Product Bool (fun b => if b then x else y).
 Proof.
-  snrapply Build_Is0Functor.
-  intros a b f.
-  apply cat_prod_corec.
-  - exact (f $o cat_pr1).
-  - exact cat_pr2.
+  snrapply (Build_Product _ cat_binprod).
+  - intros [|].
+    + exact cat_pr1.
+    + exact cat_pr2.
+  - intros z f.
+    nrapply cat_binprod_corec.
+    + exact (f true).
+    + exact (f false).
+  - intros z f [|].
+    + nrapply cat_binprod_beta_pr1.
+    + nrapply cat_binprod_beta_pr2.
+  - intros z f g p.
+    nrapply cat_binprod_eta_pr.
+    + exact (p true).
+    + exact (p false).
 Defined.
 
-Global Instance is1functor_cat_prod_l {A : Type}
-  `{HasBinaryProducts A} y
-  : Is1Functor (fun x => cat_prod x y).
+Definition cat_binprod_eta_pr_x_xx {A : Type} `{HasBinaryProducts A} {w x y z : A}
+  (f g : w $-> cat_binprod x (cat_binprod y z))
+  : cat_pr1 $o f $== cat_pr1 $o g
+  -> cat_pr1 $o cat_pr2 $o f $== cat_pr1 $o cat_pr2 $o g
+  -> cat_pr2 $o cat_pr2 $o f $== cat_pr2 $o cat_pr2 $o g
+  -> f $== g.
 Proof.
-  snrapply Build_Is1Functor.
-  - intros a b f g p.
-    simpl.
-    apply cat_prod_corec_eta.
-    2: apply Id.
-    exact (p $@R cat_pr1).
-  - intros x.
-    simpl.
-    apply cat_prod_pr_eta.
-    + refine (cat_prod_beta_pr1 _ _ $@ _).
-      exact (cat_idl _ $@ (cat_idr _)^$).
-    + refine (cat_prod_beta_pr2 _ _ $@ _).
-      exact (cat_idr _)^$.
-  - intros x z w f g.
-    simpl.
-    apply cat_prod_pr_eta.
-    + refine (cat_prod_beta_pr1 _ _ $@ _).
-      refine (_ $@ cat_assoc _ _ _).
-      refine (_ $@ ((cat_prod_beta_pr1 _ _)^$ $@R _)).
-      refine (cat_assoc _ _ _ $@ (_ $@L _) $@ (cat_assoc _ _ _)^$).
-      exact (cat_prod_beta_pr1 _ _)^$.
-    + refine (cat_prod_beta_pr2 _ _ $@ _).
-      refine (_ $@ cat_assoc _ _ _).
-      refine (_ $@ ((cat_prod_beta_pr2 _ _)^$ $@R _)).
-      exact (cat_prod_beta_pr2 _ _)^$.
+  intros p q r.
+  snrapply cat_binprod_eta_pr.
+  - exact p.
+  - snrapply cat_binprod_eta_pr.
+    + exact (cat_assoc_opp _ _ _ $@ q $@ cat_assoc _ _ _).
+    + exact (cat_assoc_opp _ _ _ $@ r $@ cat_assoc _ _ _).
 Defined.
 
-Global Instance is0functor_cat_prod_r {A : Type}
-  `{HasBinaryProducts A} x
-  : Is0Functor (fun y => cat_prod x y).
+Definition cat_binprod_eta_pr_xx_x {A : Type} `{HasBinaryProducts A} {w x y z : A}
+  (f g : w $-> cat_binprod (cat_binprod x y) z)
+  : cat_pr1 $o cat_pr1 $o f $== cat_pr1 $o cat_pr1 $o g
+  -> cat_pr2 $o cat_pr1 $o f $== cat_pr2 $o cat_pr1 $o g
+  -> cat_pr2 $o f $== cat_pr2 $o g
+  -> f $== g.
 Proof.
+  intros p q r.
+  snrapply cat_binprod_eta_pr.
+  2: exact r.
+  snrapply cat_binprod_eta_pr.
+  1,2: refine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _).
+  - exact p.
+  - exact q.
+Defined.
+
+Definition cat_binprod_eta_pr_x_xx_id {A : Type} `{HasBinaryProducts A} {x y z : A}
+  (f : cat_binprod x (cat_binprod y z) $-> cat_binprod x (cat_binprod y z))
+  : cat_pr1 $o f $== cat_pr1
+  -> cat_pr1 $o cat_pr2 $o f $== cat_pr1 $o cat_pr2
+  -> cat_pr2 $o cat_pr2 $o f $== cat_pr2 $o cat_pr2
+  -> f $== Id _.
+Proof.
+  intros p q r.
+  snrapply cat_binprod_eta_pr_x_xx.
+  - exact (p $@ (cat_idr _)^$).
+  - exact (q $@ (cat_idr _)^$).
+  - exact (r $@ (cat_idr _)^$).
+Defined.
+
+(** From binary products, all Bool-shaped products can be constructed. This should not be an instance to avoid a cycle with [hasbinaryproducts_hasproductsbool]. *)
+Definition hasproductsbool_hasbinaryproducts {A : Type} `{HasBinaryProducts A}
+  : HasProducts Bool A.
+Proof.
+  intros x.
+  snrapply Build_Product.
+  - exact (cat_binprod (x true) (x false)).
+  - intros [|].
+    + exact cat_pr1.
+    + exact cat_pr2.
+  - intros z f.
+    exact (cat_binprod_corec (f true) (f false)).
+  - intros z f [|].
+    + exact (cat_binprod_beta_pr1 (f true) (f false)).
+    + exact (cat_binprod_beta_pr2 (f true) (f false)).
+  - intros z f g p.
+    nrapply cat_binprod_eta_pr.
+    + exact (p true).
+    + exact (p false).
+Defined.
+
+(** *** Operations on indexed products *)
+
+(** We can take the disjoint union of the index set of an indexed product if we have all binary products. This is useful for associating products in a canonical way. This leads to symmetry and associativity of binary products. *)
+
+Definition cat_prod_index_sum {I J : Type} {A : Type} `{HasBinaryProducts A}
+  (x : I -> A) (y : J -> A)
+  : Product I x -> Product J y -> Product (I + J) (sum_ind _ x y).
+Proof.
+  intros p q.
+  snrapply Build_Product.
+  - exact (cat_binprod (cat_prod I x) (cat_prod J y)).
+  - intros [i | j].
+    + exact (cat_pr _ $o cat_pr1).
+    + exact (cat_pr _ $o cat_pr2).
+  - intros z f.
+    nrapply cat_binprod_corec.
+    + nrapply cat_prod_corec.
+      exact (f o inl).
+    + nrapply cat_prod_corec.
+      exact (f o inr).
+  - intros z f [i | j].
+    + nrefine (cat_assoc _ _ _ $@ _).
+      nrefine ((_ $@L cat_binprod_beta_pr1 _ _) $@ _).
+      rapply cat_prod_beta.
+    + nrefine (cat_assoc _ _ _ $@ _).
+      nrefine ((_ $@L cat_binprod_beta_pr2 _ _) $@ _).
+      rapply cat_prod_beta.
+  - intros z f g r.
+    rapply cat_binprod_eta_pr.
+    + rapply  cat_prod_pr_eta.
+      intros i.
+      exact ((cat_assoc _ _ _)^$ $@ r (inl i) $@ cat_assoc _ _ _).
+    + rapply  cat_prod_pr_eta.
+      intros j.
+      exact ((cat_assoc _ _ _)^$ $@ r (inr j) $@ cat_assoc _ _ _).
+Defined.
+
+(** *** Binary product functor *)
+
+(** We prove bifunctoriality of [cat_binprod : A -> A -> A] by factoring it as [cat_prod Bool o Bool_rec A]. First, we prove that [Bool_rec A : A -> A -> (Bool -> A)] is a bifunctor. *)
+Local Instance is0bifunctor_boolrec {A : Type} `{Is1Cat A}
+  : Is0Bifunctor (Bool_rec A).
+Proof.
+  snrapply Build_Is0Bifunctor'.
+  1,2: exact _.
   snrapply Build_Is0Functor.
-  intros a b f.
-  apply cat_prod_corec.
-  - exact cat_pr1.
-  - exact (f $o cat_pr2).
+  intros [a b] [a' b'] [f g] [ | ].
+  - exact f.
+  - exact g.
 Defined.
 
-Global Instance is1functor_cat_prod_r {A : Type}
-  `{HasBinaryProducts A} x
-  : Is1Functor (fun y => cat_prod x y).
+Local Instance is1bifunctor_boolrec {A : Type} `{Is1Cat A}
+  : Is1Bifunctor (Bool_rec A).
 Proof.
+  snrapply Build_Is1Bifunctor'.
   snrapply Build_Is1Functor.
-  - intros y z f g p.
-    apply cat_prod_corec_eta.
-    1: apply Id.
-    exact (p $@R cat_pr2).
-  - intros y. simpl.
-    refine (_ $@ cat_prod_eta _).
-    apply cat_prod_corec_eta.
-    + symmetry.
-      apply cat_idr.
-    + exact (cat_idl _ $@ (cat_idr _)^$).
-  - intros y z w f g.
-    simpl.
-    apply cat_prod_pr_eta.
-    + refine (cat_prod_beta_pr1 _ _ $@ _).
-      refine (_ $@ cat_assoc _ _ _).
-      refine (_ $@ ((cat_prod_beta_pr1 _ _)^$ $@R _)).
-      exact (cat_prod_beta_pr1 _ _)^$.
-    + refine (cat_prod_beta_pr2 _ _ $@ _).
-      refine (_ $@ cat_assoc _ _ _).
-      refine (_ $@ ((cat_prod_beta_pr2 _ _)^$ $@R _)).
-      refine (_ $@ (cat_assoc _ _ _)^$).
-      refine (cat_assoc _ _ _ $@ _).
-      exact (_ $@L cat_prod_beta_pr2 _ _)^$.
+  - intros [a b] [a' b'] [f g] [f' g'] [p q] [ | ].
+    + exact p.
+    + exact q.
+  - intros [a b] [ | ]; reflexivity.
+  - intros [a b] [a' b'] [a'' b''] [f f'] [g g'] [ | ]; reflexivity.
+Defined.
+
+(** As a special case of the product functor, restriction along [Bool_rec A] yields bifunctoriality of [cat_binprod]. *)
+Global Instance is0bifunctor_cat_binprod {A : Type} `{HasBinaryProducts A}
+  : Is0Bifunctor (fun x y => cat_binprod x y).
+Proof.
+  pose (p:=@has_products _ _ _ _ _ _ hasproductsbool_hasbinaryproducts).
+  exact (is0bifunctor_postcompose
+          (Bool_rec A) (fun x => cat_prod Bool x (product:=p x))).
 Defined.
 
-(** [cat_prod_corec] is also functorial in each morphsism. *)
+Global Instance is1bifunctor_cat_binprod {A : Type} `{HasBinaryProducts A}
+  : Is1Bifunctor (fun x y => cat_binprod x y).
+Proof.
+  pose (p:=@has_products _ _ _ _ _ _ hasproductsbool_hasbinaryproducts).
+  exact (is1bifunctor_postcompose
+          (Bool_rec A) (fun x => cat_prod Bool x (product:=p x))).
+Defined.
 
-Global Instance is0functor_cat_prod_corec_l {A : Type}
+(** Binary products are functorial in each argument. *)
+Global Instance is0functor_cat_binprod_l {A : Type} `{HasBinaryProducts A}
+  (y : A)
+  : Is0Functor (fun x => cat_binprod x y).
+Proof.
+  exact (is0functor10_bifunctor _ y).
+Defined.
+
+Global Instance is1functor_cat_binprod_l {A : Type} `{HasBinaryProducts A}
+  (y : A)
+  : Is1Functor (fun x => cat_binprod x y).
+Proof.
+  exact (is1functor10_bifunctor _ y).
+Defined.
+
+Global Instance is0functor_cat_binprod_r {A : Type} `{HasBinaryProducts A}
+  (x : A)
+  : Is0Functor (fun y => cat_binprod x y).
+Proof.
+  exact (is0functor01_bifunctor _ x).
+Defined.
+
+Global Instance is1functor_cat_binprod_r {A : Type} `{HasBinaryProducts A}
+  (x : A)
+  : Is1Functor (fun y => cat_binprod x y).
+Proof.
+  exact (is1functor01_bifunctor _ x).
+Defined.
+
+(** [cat_binprod_corec] is also functorial in each morphsism. *)
+
+Global Instance is0functor_cat_binprod_corec_l {A : Type}
   `{HasBinaryProducts A} {x y z : A} (g : z $-> y)
-  : Is0Functor (fun f : z $-> y => cat_prod_corec f g).
+  : Is0Functor (fun f : z $-> y => cat_binprod_corec f g).
 Proof.
   snrapply Build_Is0Functor.
   intros f f' p.
-  by apply cat_prod_corec_eta.
+  by nrapply cat_binprod_corec_eta.
 Defined.
 
-Global Instance is0functor_cat_prod_corec_r {A : Type}
+Global Instance is0functor_cat_binprod_corec_r {A : Type}
   `{HasBinaryProducts A} {x y z : A} (f : z $-> x)
-  : Is0Functor (fun g : z $-> x => cat_prod_corec f g).
+  : Is0Functor (fun g : z $-> x => cat_binprod_corec f g).
 Proof.
   snrapply Build_Is0Functor.
   intros g h p.
-  by apply cat_prod_corec_eta.
+  by nrapply cat_binprod_corec_eta.
 Defined.
 
-(** Since we use the Yoneda lemma in this file, we therefore depend on WildCat.Universe which means this instance has to therefore live here. *)
-Global Instance hasbinaryproducts_type : HasBinaryProducts Type.
+Definition cat_pr1_fmap01_binprod {A : Type} `{HasBinaryProducts A}
+  (a : A) {x y : A} (g : x $-> y)
+  : cat_pr1 $o fmap01 (fun x y => cat_binprod x y) a g $== cat_pr1
+  := cat_binprod_beta_pr1 _ _ $@ cat_idl _.
+
+Definition cat_pr1_fmap10_binprod {A : Type} `{HasBinaryProducts A}
+  {x y : A} (f : x $-> y) (a : A)
+  : cat_pr1 $o fmap10 (fun x y => cat_binprod x y) f a $== f $o cat_pr1
+  := cat_binprod_beta_pr1 _ _.
+
+Definition cat_pr1_fmap11_binprod {A : Type} `{HasBinaryProducts A}
+  {w x y z : A} (f : w $-> y) (g : x $-> z)
+  : cat_pr1 $o fmap11 (fun x y => cat_binprod x y) f g $== f $o cat_pr1
+  := cat_binprod_beta_pr1 _ _.
+
+Definition cat_pr2_fmap01_binprod {A : Type} `{HasBinaryProducts A}
+  (a : A) {x y : A} (g : x $-> y)
+  : cat_pr2 $o fmap01 (fun x y => cat_binprod x y) a g $== g $o cat_pr2
+  := cat_binprod_beta_pr2 _ _.
+
+Definition cat_pr2_fmap10_binprod {A : Type} `{HasBinaryProducts A}
+  {x y : A} (f : x $-> y) (a : A)
+  : cat_pr2 $o fmap10 (fun x y => cat_binprod x y) f a $== cat_pr2
+  := cat_binprod_beta_pr2 _ _ $@ cat_idl _.
+
+Definition cat_pr2_fmap11_binprod {A : Type} `{HasBinaryProducts A}
+  {w x y z : A} (f : w $-> y) (g : x $-> z)
+  : cat_pr2 $o fmap11 (fun x y => cat_binprod x y) f g $== g $o cat_pr2
+  := cat_binprod_beta_pr2 _ _.
+
+(** *** Diagonal *)
+
+(** Annoyingly this doesn't follow directly from the general diagonal since [fun b => if b then x else x] is not definitionally equal to [fun _ => x]. *)
+Definition cat_binprod_diag {A : Type}
+  `{Is1Cat A} (x : A) `{!BinaryProduct x x}
+  : x $-> cat_binprod x x.
 Proof.
-  intros X Y.
-  snrapply Build_BinaryProduct.
-  - exact (X * Y).
-  - exact fst.
-  - exact snd.
-  - intros Z f g z. exact (f z, g z).
-  - reflexivity.
-  - reflexivity.
-  - intros Z f g p q x.
-    apply path_prod.
-    + exact (p x).
-    + exact (q x).
+  snrapply cat_binprod_corec; exact (Id _).
+Defined.
+
+(** *** Lemmas about [cat_binprod_corec] *)
+
+Definition cat_binprod_fmap01_corec {A : Type}
+  `{Is1Cat A, !HasBinaryProducts A} {w x y z : A}
+  (f : w $-> z) (g : x $-> y) (h : w $-> x)
+  : fmap01 (fun x y => cat_binprod x y) z g $o cat_binprod_corec f h
+    $== cat_binprod_corec f (g $o h).
+Proof.
+  snrapply cat_binprod_eta_pr.
+  - nrefine (cat_assoc_opp _ _ _ $@ _).
+    refine ((_ $@R _) $@ cat_assoc _ _ _ $@ cat_idl _ $@ _ $@ _^$).
+    1-3: rapply cat_binprod_beta_pr1.
+  - nrefine (cat_assoc_opp _ _ _ $@ _).
+    refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ _^$).
+    1-3: rapply cat_binprod_beta_pr2.
+Defined.
+
+Definition cat_binprod_fmap10_corec {A : Type}
+  `{Is1Cat A, !HasBinaryProducts A} {w x y z : A}
+  (f : x $-> y) (g : w $-> x) (h : w $-> z)
+  : fmap10 (fun x y => cat_binprod x y) f z $o cat_binprod_corec g h
+    $== cat_binprod_corec (f $o g) h.
+Proof.
+  snrapply cat_binprod_eta_pr.
+  - refine (cat_assoc_opp _ _ _ $@ _).
+    refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ _^$).
+    1-3: nrapply cat_binprod_beta_pr1.
+  - refine (cat_assoc_opp _ _ _ $@ _).
+    refine ((_ $@R _) $@ cat_assoc _ _ _ $@ cat_idl _ $@ _ $@ _^$).
+    1-3: nrapply cat_binprod_beta_pr2.
 Defined.
 
-(** *** Associativity of products *)
+Definition cat_binprod_fmap11_corec {A : Type}
+  `{Is1Cat A, !HasBinaryProducts A} {v w x y z : A}
+  (f : w $-> y) (g : x $-> z) (h : v $-> w) (i : v $-> x)
+  : fmap11 (fun x y => cat_binprod x y) f g $o cat_binprod_corec h i
+    $== cat_binprod_corec (f $o h) (g $o i).
+Proof.
+  snrapply cat_binprod_eta_pr.
+  - refine (cat_assoc_opp _ _ _ $@ _).
+    refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ _^$).
+    1-3: nrapply cat_binprod_beta_pr1.
+  - nrefine (cat_assoc_opp _ _ _ $@ _).
+    refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ _^$).
+    1-3: rapply cat_binprod_beta_pr2.
+Defined.
+
+(** *** Symmetry of binary products *)
+
+Section Symmetry.
+
+  (** The requirement of having all binary products can be weakened further to having specific binary products, but it is not clear this is a useful generality. *)
+  Context {A : Type} `{HasEquivs A} `{!HasBinaryProducts A}.
+
+  Definition cat_binprod_swap (x y : A) : cat_binprod x y $-> cat_binprod y x
+    := cat_binprod_corec cat_pr2 cat_pr1.
+
+  Lemma cat_binprod_swap_cat_binprod_swap (x y : A)
+    : cat_binprod_swap x y $o cat_binprod_swap y x $== Id _.
+  Proof.
+    nrapply cat_binprod_eta_pr.
+    - refine ((cat_assoc _ _ _)^$ $@ _).
+      nrefine (cat_binprod_beta_pr1 _ _ $@R _ $@ _).
+      exact (cat_binprod_beta_pr2 _ _ $@ (cat_idr _)^$).
+    - refine ((cat_assoc _ _ _)^$ $@ _).
+      nrefine (cat_binprod_beta_pr2 _ _ $@R _ $@ _).
+      exact (cat_binprod_beta_pr1 _ _ $@ (cat_idr _)^$).
+  Defined.
+
+  Lemma cate_binprod_swap (x y : A)
+    : cat_binprod x y $<~> cat_binprod y x.
+  Proof.
+    snrapply cate_adjointify.
+    1,2: nrapply cat_binprod_swap.
+    all: nrapply cat_binprod_swap_cat_binprod_swap.
+  Defined.
+
+  Definition cat_binprod_swap_corec {a b c : A} (f : a $-> b) (g : a $-> c)
+    : cat_binprod_swap b c $o cat_binprod_corec f g $== cat_binprod_corec g f.
+  Proof.
+    nrapply cat_binprod_eta_pr.
+    - refine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ (_ $@ _^$)).
+      1,3: nrapply cat_binprod_beta_pr1.
+      nrapply cat_binprod_beta_pr2.
+    - refine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ (_ $@ _^$)).
+      1,3: nrapply cat_binprod_beta_pr2.
+      nrapply cat_binprod_beta_pr1.
+  Defined.
+
+  Definition cat_binprod_swap_nat {a b c d : A} (f : a $-> c) (g : b $-> d)
+    : cat_binprod_swap c d $o fmap11 (fun x y : A => cat_binprod x y) f g
+    $== fmap11 (fun x y : A => cat_binprod x y) g f $o cat_binprod_swap a b
+    := cat_binprod_swap_corec _ _ $@ (cat_binprod_fmap11_corec _ _ _ _)^$.
+
+  Local Instance symmetricbraiding_binprod
+    : SymmetricBraiding (fun x y => cat_binprod x y).
+  Proof.
+    snrapply Build_SymmetricBraiding.
+    - snrapply Build_NatTrans.
+      + intros [x y].
+        exact (cat_binprod_swap x y).
+      + snrapply Build_Is1Natural.
+        intros [a b] [c d] [f g]; cbn in f, g.
+        exact(cat_binprod_swap_nat f g).
+    - exact cat_binprod_swap_cat_binprod_swap.
+  Defined.
+
+End Symmetry.
+
+(** *** Associativity of binary products *)
 
 Section Associativity.
 
   Context {A : Type} `{HasEquivs A} `{!HasBinaryProducts A}.
 
-  Definition cat_prod_twist (x y z : A)
-    : cat_prod x (cat_prod y z) $-> cat_prod y (cat_prod x z).
+  Definition cat_binprod_twist (x y z : A)
+    : cat_binprod x (cat_binprod y z) $-> cat_binprod y (cat_binprod x z).
   Proof.
-    apply cat_prod_corec.
+    nrapply cat_binprod_corec.
     - exact (cat_pr1 $o cat_pr2).
-    - exact (fmap (fun y => cat_prod x y) cat_pr2).
+    - exact (fmap01 (fun x y => cat_binprod x y) x cat_pr2).
   Defined.
 
-  Lemma cat_prod_twist_cat_prod_twist (x y z : A)
-    : cat_prod_twist x y z $o cat_prod_twist y x z $== Id _.
+  Definition cat_binprod_pr1_twist (x y z : A)
+    : cat_pr1 $o cat_binprod_twist x y z $== cat_pr1 $o cat_pr2
+    := cat_binprod_beta_pr1 _ _.
+
+  Definition cat_binprod_pr1_pr2_twist (x y z : A)
+    : cat_pr1 $o cat_pr2 $o cat_binprod_twist x y z $== cat_pr1.
   Proof.
-    unfold cat_prod_twist.
-    apply cat_prod_pr_eta.
-    - refine ((cat_assoc _ _ _)^$ $@ _).
-      refine (cat_prod_beta_pr1 _ _ $@R _ $@ _).
-      refine (cat_assoc _ _ _ $@ _).
-      refine (_ $@L cat_prod_beta_pr2 _ _ $@ _).
-      refine (cat_prod_beta_pr1 _ _ $@ _).
-      exact (cat_idr _)^$.
-    - refine ((cat_assoc _ _ _)^$ $@ _).
-      refine (cat_prod_beta_pr2 _ _ $@R _ $@ _).
-      apply cat_prod_pr_eta.
-      + refine ((cat_assoc _ _ _)^$ $@ _).
-        refine (cat_prod_beta_pr1 _ _ $@R _ $@ _).
-        refine (cat_prod_beta_pr1 _ _ $@ _).
-        refine (_ $@L _).
-        exact (cat_idr _)^$.
-      + refine ((cat_assoc _ _ _)^$ $@ _).
-        refine (cat_prod_beta_pr2 _ _ $@R _ $@ _).
-        refine (cat_assoc _ _ _ $@ _).
-        refine (_ $@L cat_prod_beta_pr2 _ _ $@ _).
-        refine (cat_prod_beta_pr2 _ _ $@ _).
-        refine (_ $@L _).
-        exact (cat_idr _)^$.
-  Defined.
-
-  Definition cate_prod_twist (x y z : A)
-    : cat_prod x (cat_prod y z) $<~> cat_prod y (cat_prod x z).
+    nrefine (cat_assoc _ _ _ $@ _).
+    nrefine ((_ $@L cat_binprod_beta_pr2 _ _) $@ _).
+    nrapply cat_pr1_fmap01_binprod.
+  Defined.
+
+  Definition cat_binprod_pr2_pr2_twist (x y z : A)
+    : cat_pr2 $o cat_pr2 $o cat_binprod_twist x y z $== cat_pr2 $o cat_pr2.
+  Proof.
+    nrefine (cat_assoc _ _ _ $@ _).
+    nrefine ((_ $@L cat_binprod_beta_pr2 _ _) $@ _).
+    nrapply cat_pr2_fmap01_binprod.
+  Defined.
+  
+  Definition cat_binprod_twist_corec {w x y z : A}
+    (f : w $-> x) (g : w $-> y) (h : w $-> z)
+    : cat_binprod_twist x y z $o cat_binprod_corec f (cat_binprod_corec g h)
+      $== cat_binprod_corec g (cat_binprod_corec f h).
+  Proof.
+    nrapply cat_binprod_eta_pr.
+    - nrefine (cat_assoc_opp _ _ _ $@ _).
+      refine ((_ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L _) $@ (_ $@ _^$)).
+      1: nrapply cat_binprod_pr1_twist.
+      1: nrapply cat_binprod_beta_pr2.
+      1,2: nrapply cat_binprod_beta_pr1.
+    - refine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _ $@ (cat_binprod_beta_pr2 _ _)^$).
+      1: nrapply cat_binprod_beta_pr2.
+      nrefine (cat_binprod_fmap01_corec _ _ _ $@ _).
+      nrapply cat_binprod_corec_eta.
+      1: exact (Id _).
+      nrapply cat_binprod_beta_pr2.
+  Defined.
+
+  Lemma cat_binprod_twist_cat_binprod_twist (x y z : A)
+    : cat_binprod_twist x y z $o cat_binprod_twist y x z $== Id _.
+  Proof.
+    nrapply cat_binprod_eta_pr_x_xx_id.
+    - nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_pr1_twist _ _ _ $@R _) $@ _).
+      nrapply cat_binprod_pr1_pr2_twist.
+    - nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_pr1_pr2_twist _ _ _ $@R _) $@ _).
+      nrapply cat_binprod_pr1_twist.
+    - nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_pr2_pr2_twist _ _ _ $@R _) $@ _).
+      nrapply cat_binprod_pr2_pr2_twist.
+  Defined.
+
+  Definition cate_binprod_twist (x y z : A)
+    : cat_binprod x (cat_binprod y z) $<~> cat_binprod y (cat_binprod x z).
   Proof.
     snrapply cate_adjointify.
-    1,2: apply cat_prod_twist.
-    1,2: apply cat_prod_twist_cat_prod_twist.
+    1,2: nrapply cat_binprod_twist.
+    1,2: nrapply cat_binprod_twist_cat_binprod_twist.
+  Defined.
+
+  Definition cat_binprod_twist_nat {a a' b b' c c' : A}
+    (f : a $-> a') (g : b $-> b') (h : c $-> c')
+    : cat_binprod_twist a' b' c'
+        $o fmap11 (fun x y => cat_binprod x y) f (fmap11 (fun x y => cat_binprod x y) g h)
+      $== fmap11 (fun x y => cat_binprod x y) g (fmap11 (fun x y => cat_binprod x y) f h)
+        $o cat_binprod_twist a b c.
+  Proof.
+    nrapply cat_binprod_eta_pr.
+    - refine (cat_assoc_opp _ _ _ $@ _).
+      nrefine ((cat_binprod_beta_pr1 _ _ $@R _) $@ _).
+      nrefine (cat_assoc _ _ _ $@ _).
+      nrefine ((_ $@L _) $@ _).
+      1: nrapply cat_pr2_fmap11_binprod.
+      nrefine (cat_assoc_opp _ _ _ $@ _).
+      nrefine ((_ $@R _) $@ _).
+      1: nrapply cat_pr1_fmap11_binprod.
+      nrefine (_ $@ cat_assoc _ _ _).
+      refine (_ $@ (_^$ $@R _)).
+      2: nrapply cat_pr1_fmap11_binprod.
+      refine (cat_assoc _ _ _ $@ (_ $@L _^$) $@ (cat_assoc _ _ _)^$).
+      nrapply cat_binprod_beta_pr1.
+    - nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr2 _ _ $@R _) $@ _).
+      nrefine (_ $@ cat_assoc _ _ _).
+      refine (_ $@ (_^$ $@R _)).
+      2: nrapply cat_pr2_fmap11_binprod.
+      refine (_ $@ (_ $@L _^$) $@ (cat_assoc _ _ _)^$).
+      2: nrapply cat_binprod_beta_pr2.
+      refine (_^$ $@ _ $@ _).
+      1,3: rapply fmap11_comp.
+      rapply fmap22.
+      1: exact (cat_idl _ $@ (cat_idr _)^$).
+      nrapply cat_binprod_beta_pr2.
+  Defined.
+
+  Local Existing Instance symmetricbraiding_binprod.
+
+  Local Instance associator_cat_binprod : Associator (fun x y => cat_binprod x y).
+  Proof.
+    snrapply associator_twist.
+    - exact _.
+    - exact cat_binprod_twist.
+    - exact cat_binprod_twist_cat_binprod_twist.
+    - intros ? ? ? ? ? ?; exact cat_binprod_twist_nat.
+  Defined.
+
+  Definition cat_pr1_pr1_associator_binprod x y z
+    : cat_pr1 $o cat_pr1 $o associator_cat_binprod x y z $== cat_pr1.
+  Proof.
+    nrefine ((_ $@L Monoidal.associator_twist'_unfold _ _ _ _ _ _ _ _) $@ _).
+    nrefine (cat_assoc _ _ _ $@ (_ $@L (cat_assoc_opp _ _ _ $@ (_ $@R _))) $@ _).
+    1: nrapply cat_binprod_beta_pr1.
+    do 2 nrefine (cat_assoc_opp _ _ _ $@ _).
+    nrefine ((cat_binprod_pr1_pr2_twist _ _ _ $@R _) $@ _).
+    nrapply cat_pr1_fmap01_binprod.
   Defined.
 
-  Lemma cate_prod_assoc (x y z : A)
-    : cat_prod x (cat_prod y z) $<~> cat_prod (cat_prod x y) z.
+  Definition cat_pr2_pr1_associator_binprod x y z
+    : cat_pr2 $o cat_pr1 $o associator_cat_binprod x y z $== cat_pr1 $o cat_pr2.
   Proof.
-    refine (cate_prod_swap _ _ $oE _).
-    refine (cate_prod_twist _ _ _ $oE _).
-    refine (emap (fun y => cat_prod x y) _).
-    exact (cate_prod_swap _ _).
+    nrefine ((_ $@L Monoidal.associator_twist'_unfold _ _ _ _ _ _ _ _) $@ _).
+    nrefine (cat_assoc _ _ _ $@ (_ $@L (cat_assoc_opp _ _ _ $@ (_ $@R _))) $@ _).
+    1: nrapply cat_binprod_beta_pr1.
+    do 2 nrefine (cat_assoc_opp _ _ _ $@ _).
+    nrefine ((cat_binprod_pr2_pr2_twist _ _ _ $@R _) $@ _).
+    nrefine (cat_assoc _ _ _ $@ (_ $@L cat_pr2_fmap01_binprod _ _) $@ _).
+    exact (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr2 _ _ $@R _)).
   Defined.
 
+  Definition cat_pr2_associator_binprod x y z
+    : cat_pr2 $o associator_cat_binprod x y z $== cat_pr2 $o cat_pr2.
+  Proof.
+    nrefine ((_ $@L Monoidal.associator_twist'_unfold _ _ _ _ _ _ _ _) $@ _).
+    nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr2 _ _ $@R _) $@ _).
+    nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_pr1_twist _ _ _ $@R _) $@ _).
+    nrefine (cat_assoc _ _ _ $@ (_ $@L cat_pr2_fmap01_binprod _ _) $@ _).
+    exact (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr1 _ _ $@R _)).
+  Defined.
+  
+  Definition cat_binprod_associator_corec {w x y z}
+    (f : w $-> x) (g : w $-> y) (h : w $-> z)
+    : associator_cat_binprod x y z $o cat_binprod_corec f (cat_binprod_corec g h)
+      $== cat_binprod_corec (cat_binprod_corec f g) h. 
+  Proof.
+    nrefine ((Monoidal.associator_twist'_unfold _ _ _ _ _ _ _ _ $@R _) $@ _).
+    nrefine ((cat_assoc_opp _ _ _ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L (_ $@ _)) $@ _). 
+    1: nrapply cat_binprod_fmap01_corec.
+    1: rapply (cat_binprod_corec_eta _ _ _ _ (Id _)).
+    1: nrapply cat_binprod_swap_corec.
+    nrefine (cat_assoc _ _ _ $@ (_ $@L _) $@ _).
+    1: nrapply cat_binprod_twist_corec.
+    nrapply cat_binprod_swap_corec.
+  Defined.
+
+  Context (unit : A) `{!IsTerminal unit}.
+
+  Local Instance right_unitor_binprod
+    : RightUnitor (fun x y => cat_binprod x y) unit.
+  Proof.
+    snrapply Build_NatEquiv.
+    - intros a; unfold flip.
+      snrapply cate_adjointify.
+      + exact cat_pr1.
+      + exact (cat_binprod_corec (Id _) (mor_terminal _ _)).
+      + exact (cat_binprod_beta_pr1 _ _).
+      + nrapply cat_binprod_eta_pr.
+        * nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr1 _ _ $@R _) $@ _).
+          exact (cat_idl _ $@ (cat_idr _)^$).
+        * nrefine (cat_assoc_opp _ _ _ $@ (cat_binprod_beta_pr2 _ _ $@R _) $@ _).
+          exact ((mor_terminal_unique _ _ _)^$ $@ mor_terminal_unique _ _ _).
+    - snrapply Build_Is1Natural.
+      intros a b f.
+      refine ((_ $@R _) $@ _ $@ (_ $@L _^$)).
+      1,3: nrapply cate_buildequiv_fun.
+      nrapply cat_binprod_beta_pr1.
+  Defined.
+
+  Local Existing Instance left_unitor_twist.
+
+  Local Instance triangle_binprod
+    : TriangleIdentity (fun x y => cat_binprod x y) unit.
+  Proof.
+    snrapply triangle_twist.
+    intros a b.
+    refine (fmap02 _ _ _ $@ _ $@ ((_ $@L fmap02 _ _ _^$) $@R _)).
+    1,3: nrapply cate_buildequiv_fun.
+    nrapply cat_binprod_eta_pr.
+    - nrefine (cat_pr1_fmap01_binprod _ _ $@ _ $@ cat_assoc _ _ _).
+      refine (_ $@ (((_^$ $@R _) $@ cat_assoc _ _ _) $@R _)).
+      2: nrapply cat_binprod_beta_pr1.
+      refine ((_ $@R _) $@ _)^$.
+      1: nrapply cat_pr2_fmap01_binprod.
+      nrapply cat_binprod_pr1_pr2_twist.
+    - nrefine (cat_pr2_fmap01_binprod _ _ $@ _ $@ cat_assoc _ _ _).
+      refine (_ $@ (((cat_binprod_beta_pr2 _ _)^$ $@R _) $@ cat_assoc _ _ _ $@R _)).
+      refine ((_ $@R _) $@ _)^$.
+      1: nrapply cat_pr1_fmap01_binprod.
+      nrapply cat_binprod_beta_pr1.
+  Defined.
+
+  Local Instance pentagon_binprod
+    : PentagonIdentity (fun x y => cat_binprod x y).
+  Proof.
+    intros a b c d.
+    nrapply cat_binprod_eta_pr_xx_x.
+    - nrefine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _).
+      1: nrapply cat_pr1_pr1_associator_binprod.
+      refine (_ $@ (_ $@L ((((_^$ $@R _) $@ cat_assoc _ _ _) $@R _)
+        $@ cat_assoc _ _ _)) $@ cat_assoc_opp _ _ _).
+      2: nrapply cat_pr1_fmap10_binprod.
+      do 2 nrefine (_ $@ (_ $@L cat_assoc_opp _ _ _)).
+      nrapply cat_binprod_eta_pr.
+      + nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _).
+        refine (_ $@ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _).
+        1,3: nrapply cat_pr1_pr1_associator_binprod.
+        do 2 nrefine (_ $@ cat_assoc _ _ _).
+        refine (_^$ $@ (_^$ $@R _)).
+        2: nrapply cat_pr1_pr1_associator_binprod.
+        nrapply cat_pr1_fmap01_binprod.
+      + nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _).
+        refine (_ $@ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _).
+        1,3: nrapply cat_pr2_pr1_associator_binprod.
+        do 2 nrefine (_ $@ cat_assoc _ _ _).
+        refine (_ $@ ((cat_assoc _ _ _ $@ (_ $@L (_^$ $@ cat_assoc _ _ _))
+          $@ cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _) $@R _)).
+        2: nrapply cat_pr2_pr1_associator_binprod.
+        refine (_^$ $@ (_ $@L _^$) $@ cat_assoc_opp _ _ _).
+        2: nrapply cat_pr2_fmap01_binprod.
+        nrefine (cat_assoc_opp _ _ _ $@ (_ $@R _)).
+        nrapply cat_pr1_pr1_associator_binprod.
+    - nrefine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _).
+      1: nrapply cat_pr2_pr1_associator_binprod.
+      nrefine (cat_assoc _ _ _ $@ _ $@ cat_assoc_opp _ _ _).
+      nrefine ((_ $@L cat_pr2_associator_binprod _ _ _) $@ _).
+      refine (_ $@ (_ $@L ((((_^$ $@R _) $@ cat_assoc _ _ _) $@R _) $@ cat_assoc _ _ _))).
+      2: nrapply cat_pr1_fmap10_binprod.
+      nrefine (_ $@ (_ $@L (cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _))).
+      refine (_ $@ (_^$ $@R _) $@ cat_assoc _ _ _).
+      2: nrapply cat_pr2_associator_binprod.
+      refine (_ $@ (_ $@L ((_^$ $@R _) $@ cat_assoc _ _ _ $@ cat_assoc _ _ _)) $@ cat_assoc_opp _ _ _).
+      2: nrapply cat_pr2_pr1_associator_binprod.
+      refine (_ $@ (_ $@L ((_ $@L _^$) $@ cat_assoc_opp _ _ _))).
+      2: nrapply cat_pr2_fmap01_binprod.
+      refine (cat_assoc_opp _ _ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _ $@ cat_assoc _ _ _).
+      nrapply cat_pr2_pr1_associator_binprod.
+    - nrefine (cat_assoc_opp _ _ _ $@ (cat_pr2_associator_binprod _ _ _ $@R _) $@ _).
+      nrefine (cat_assoc _ _ _ $@ (_ $@L (cat_pr2_associator_binprod _ _ _)) $@ _).
+      refine (_ $@ (_^$ $@R _) $@ cat_assoc _ _ _ $@ (_ $@L (cat_assoc_opp _ _ _))).
+      2: nrapply cat_pr2_fmap10_binprod.
+      refine (_ $@ cat_assoc_opp _ _ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _).
+      2: nrapply cat_pr2_associator_binprod.
+      refine (cat_assoc_opp _ _ _ $@ (_^$ $@R _) $@ cat_assoc _ _ _
+        $@ (_ $@L (cat_pr2_fmap01_binprod _ _)^$)).
+      nrapply cat_pr2_associator_binprod.
+  Defined.
+
+  Local Instance hexagon_identity
+    : HexagonIdentity (fun x y => cat_binprod x y).
+  Proof.
+    intros a b c.
+    nrefine (cat_assoc _ _ _ $@ _ $@ cat_assoc_opp _ _ _).
+    nrapply cat_binprod_eta_pr.
+    { nrefine (cat_assoc_opp _ _ _ $@ (cat_pr1_fmap10_binprod _ _ $@R _) $@ _).
+      nrefine (cat_assoc _ _ _ $@ _).
+      nrapply cat_binprod_eta_pr.
+      { nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _ $@ cat_assoc _ _ _).
+        refine ((_ $@R _) $@ _ $@ (_^$ $@R _)).
+        1: nrapply cat_binprod_beta_pr1.
+        2: nrapply cat_pr1_pr1_associator_binprod.
+        nrefine (cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _).
+        refine ((_ $@R _) $@ _ $@ (_^$ $@R _)).
+        1: nrapply cat_pr2_pr1_associator_binprod.
+        2: nrapply cat_binprod_beta_pr1.
+        refine (cat_assoc _ _ _ $@ (_ $@L _) $@ cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _^$).
+        1: nrapply cat_pr2_fmap01_binprod.
+        2: nrapply cat_pr2_associator_binprod.
+        nrapply cat_binprod_beta_pr1. }
+      nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _ $@ cat_assoc _ _ _).
+      refine ((_ $@R _) $@ _ $@ (_^$ $@R _)).
+      1: nrapply cat_binprod_beta_pr2.
+      2: nrapply cat_pr2_pr1_associator_binprod.
+      nrefine (cat_assoc_opp _ _ _ $@ cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _).
+      refine ((_ $@R _) $@ _ $@ (((_ $@L _^$) $@ cat_assoc_opp _ _ _) $@R _)).
+      1: nrapply cat_pr1_pr1_associator_binprod.
+      2: nrapply cat_binprod_beta_pr2.
+      refine (cat_pr1_fmap01_binprod _ _ $@ _^$).
+      nrapply cat_pr1_pr1_associator_binprod. }
+    nrefine (cat_assoc_opp _ _ _ $@ _ $@ cat_assoc _ _ _ $@ cat_assoc _ _ _).
+    refine ((_ $@R _) $@ _ $@ ((_^$ $@R _) $@R _)).
+    1: nrapply cat_pr2_fmap10_binprod.
+    2: nrapply cat_pr2_associator_binprod.
+    nrefine (cat_assoc_opp _ _ _ $@ (cat_pr2_associator_binprod _ _ _ $@R _) $@ _).
+    nrefine (cat_assoc _ _ _ $@ (_ $@L _) $@ _ $@ (cat_assoc_opp _ _ _ $@R _)).
+    1: nrapply cat_pr2_fmap01_binprod.
+    refine (cat_assoc_opp _ _ _ $@ (_ $@R _) $@ _^$ $@ ((_ $@L _^$) $@R _)).
+    1,3: nrapply cat_binprod_beta_pr2.
+    nrapply cat_pr2_pr1_associator_binprod.
+  Defined.
+
+  Global Instance ismonoidal_cat_binprod
+    : IsMonoidal A (fun x y => cat_binprod x y) unit
+    := {}.
+
+  Global Instance issymmetricmonoidal_cat_binprod
+    : IsSymmetricMonoidal A (fun x y => cat_binprod x y) unit
+    := {}.
+
 End Associativity.
+
+(** *** Products in Type *)
+
+(** Since we use the Yoneda lemma in this file, we therefore depend on WildCat.Universe which means these instances have to live here. *)
+Global Instance hasbinaryproducts_type : HasBinaryProducts Type.
+Proof.
+  intros X Y.
+  snrapply Build_BinaryProduct.
+  - exact (X * Y).
+  - exact fst.
+  - exact snd.
+  - intros Z f g z. exact (f z, g z).
+  - reflexivity.
+  - reflexivity.
+  - intros Z f g p q x.
+    nrapply path_prod.
+    + exact (p x).
+    + exact (q x).
+Defined.
+
+(** Assuming [Funext], [Type] has all products. *)
+Global Instance hasallproducts_type `{Funext} : HasAllProducts Type.
+Proof.
+  intros I x.
+  snrapply Build_Product.
+  - exact (forall (i : I), x i).
+  - intros i f. exact (f i).
+  - intros A f a i. exact (f i a).
+  - reflexivity.
+  - intros A f g p a.
+    exact (path_forall _ _ (fun i => p i a)).
+Defined.
diff --git a/theories/WildCat/Sum.v b/theories/WildCat/Sum.v
index 32331dcf618..96564d6ea7f 100644
--- a/theories/WildCat/Sum.v
+++ b/theories/WildCat/Sum.v
@@ -39,25 +39,47 @@ Global Instance is1cat_sum A B `{ Is1Cat A } `{ Is1Cat B}
 Proof.
   snrapply Build_Is1Cat.
   - intros x y.
-    srapply Build_Is01Cat;
-    destruct x as [a1 | b1], y as [a2 | b2];
-    try contradiction; cbn;
-    (apply Id || intros a b c; apply cat_comp).
+    srapply Build_Is01Cat; destruct x as [a1 | b1], y as [a2 | b2].
+    2,3,6,7: contradiction.
+    all: cbn.
+    1,2: exact Id.
+    1,2: intros a b c; apply cat_comp.
   - intros x y; srapply Build_Is0Gpd.
-    destruct x as [a1 | b1], y as [a2 | b2];
-    try contradiction; cbn; intros f g; apply gpd_rev.
+    destruct x as [a1 | b1], y as [a2 | b2].
+    2,3: contradiction.
+    all: cbn; intros f g; apply gpd_rev.
   - intros x y z h; srapply Build_Is0Functor.
     intros f g p.
-    destruct x as [a1 | b1], y as [a2 | b2], z as [a3 | b3];
-    try contradiction; cbn in *; change (f $== g) in p; exact (h $@L p).
+    destruct x as [a1 | b1], y as [a2 | b2].
+    2,3: contradiction.
+    all: destruct z as [a3 | b3].
+    2,3: contradiction.
+    all: cbn in *; change (f $== g) in p; exact (h $@L p).
   - intros x y z h; srapply Build_Is0Functor.
     intros f g p.
-    destruct x as [a1 | b1], y as [a2 | b2], z as [a3 | b3];
-    try contradiction; cbn in *; change (f $== g) in p; exact (p $@R h).
-  - intros [a1 | b1] [a2 | b2] [a3 | b3] [a4 | b4] f g h;
-    try contradiction; cbn; apply cat_assoc.
-  - intros [a1 | b1] [a2 | b2] f; try contradiction;
-    cbn; apply cat_idl.
-  - intros [a1 | b1] [a2 | b2] f; try contradiction;
-    cbn; apply cat_idr.
+    destruct x as [a1 | b1], y as [a2 | b2].
+    2,3: contradiction.
+    all: destruct z as [a3 | b3].
+    2,3: contradiction.
+    all: cbn in *; change (f $== g) in p; exact (p $@R h).
+  - intros [a1 | b1] [a2 | b2].
+    2,3: contradiction.
+    all: intros [a3 | b3].
+    2,3: contradiction.
+    all: intros [a4 | b4].
+    2-3: contradiction.
+    all: intros f g h; cbn; apply cat_assoc.
+  - intros [a1 | b1] [a2 | b2].
+    2,3: contradiction.
+    all: intros [a3 | b3].
+    2,3: contradiction.
+    all: intros [a4 | b4].
+    2-3: contradiction.
+    all: intros f g h; cbn; apply cat_assoc_opp.
+  - intros [a1 | b1] [a2 | b2] f.
+    2, 3: contradiction.
+    all: cbn; apply cat_idl.
+  - intros [a1 | b1] [a2 | b2] f.
+    2, 3: contradiction.
+    all: cbn; apply cat_idr.
 Defined.
diff --git a/theories/WildCat/TwoOneCat.v b/theories/WildCat/TwoOneCat.v
index f495753252a..06716d1ae9a 100644
--- a/theories/WildCat/TwoOneCat.v
+++ b/theories/WildCat/TwoOneCat.v
@@ -1,4 +1,4 @@
-Require Import Basics.Overture.
+Require Import Basics.Overture Basics.Tactics.
 Require Import WildCat.Core.
 Require Import WildCat.NatTrans.
 
@@ -10,6 +10,9 @@ Class Is21Cat (A : Type) `{Is1Cat A, !Is3Graph A} :=
   is1gpd_hom : forall (a b : A), Is1Gpd (a $-> b) ;
   is1functor_postcomp : forall (a b c : A) (g : b $-> c), Is1Functor (cat_postcomp a g) ;
   is1functor_precomp : forall (a b c : A) (f : a $-> b), Is1Functor (cat_precomp c f) ;
+  bifunctor_coh_comp : forall {a b c : A} {f f' : a $-> b}  {g g' : b $-> c}
+    (p : f $== f') (p' : g $== g'),
+    (p' $@R f) $@ (g' $@L p) $== (g $@L p) $@ (p' $@R f') ;
 
   (** Naturality of the associator in each variable separately *)
   is1natural_cat_assoc_l : forall (a b c d : A) (f : a $-> b) (g : b $-> c),
@@ -50,3 +53,41 @@ Global Existing Instance is1natural_cat_assoc_m.
 Global Existing Instance is1natural_cat_assoc_r.
 Global Existing Instance is1natural_cat_idl.
 Global Existing Instance is1natural_cat_idr.
+
+(** *** Whiskering functoriality *)
+
+Definition cat_postwhisker_pp {A} `{Is21Cat A} {a b c : A}
+  {f g h : a $-> b} (k : b $-> c) (p : f $== g) (q : g $== h)
+  : k $@L (p $@ q) $== (k $@L p) $@ (k $@L q).
+Proof.
+  rapply fmap_comp.
+Defined.
+
+Definition cat_prewhisker_pp {A} `{Is21Cat A} {a b c : A}
+  {f g h : b $-> c} (k : a $-> b) (p : f $== g) (q : g $== h)
+  : (p $@ q) $@R k $== (p $@R k) $@ (q $@R k).
+Proof.
+  rapply fmap_comp.
+Defined.
+
+(** *** Exchange law *)
+
+Definition cat_exchange {A : Type} `{Is21Cat A} {a b c : A}
+  {f f' f'' : a $-> b} {g g' g'' : b $-> c}
+  (p : f $== f') (q : f' $== f'') (r : g $== g') (s : g' $== g'')
+  : (p $@ q) $@@ (r $@ s) $== (p $@@ r) $@ (q $@@ s).
+Proof.
+  unfold "$@@".
+  (** We use the distributivity of [$@R] and [$@L] in a (2,1)-category (since they are functors) to see that we have the same dadta on both sides of the 3-morphism. *)
+  nrefine ((_ $@L cat_prewhisker_pp _ _ _ ) $@ _).
+  nrefine ((cat_postwhisker_pp _ _ _ $@R _) $@ _).
+  (** Now we reassociate and whisker on the left and right. *)
+  nrefine (cat_assoc _ _ _ $@ _).
+  refine (_ $@ (cat_assoc _ _ _)^$).
+  nrefine (_ $@L _).
+  refine (_ $@ cat_assoc _ _ _).
+  refine ((cat_assoc _ _ _)^$ $@ _).
+  nrefine (_ $@R _).
+  (** Finally we are left with the bifunctoriality condition for left and right whiskering which is part of the data of the (2,1)-cat. *)
+  apply bifunctor_coh_comp.
+Defined.
diff --git a/theories/WildCat/Universe.v b/theories/WildCat/Universe.v
index 4add82e05de..8926c3924a0 100644
--- a/theories/WildCat/Universe.v
+++ b/theories/WildCat/Universe.v
@@ -17,10 +17,6 @@ Defined.
 Global Instance is2graph_type : Is2Graph Type
   := fun x y => Build_IsGraph _ (fun f g => f == g).
 
-(** Sometimes we need typeclasses to pick up that [A -> B] is a graph, but this cannot be done without first converting it to [A $-> B]. *)
-Global Instance isgraph_arrow {A B : Type} : IsGraph (A -> B)
-  := isgraph_hom A B.
-
 Global Instance is01cat_arrow {A B : Type} : Is01Cat (A $-> B).
 Proof.
   econstructor.
@@ -76,17 +72,7 @@ Proof.
   - intros g r s; refine (isequiv_adjointify f g r s).
 Defined.
 
-Global Instance hasmorext_core_type `{Funext}: HasMorExt (core Type).
-Proof.
-  snrapply Build_HasMorExt.
-  intros A B f g; cbn in *.
-  snrapply isequiv_homotopic.
-  - exact (GpdHom_path o (ap (x:=f) (y:=g) equiv_fun)).
-  - nrapply isequiv_compose.
-    1: apply isequiv_ap_equiv_fun.
-    exact (isequiv_Htpy_path (uncore A) (uncore B) f g).
-  - intro p; by induction p.
-Defined.
+Global Instance hasmorext_core_type `{Funext} : HasMorExt (core Type) := _.
 
 Definition catie_isequiv {A B : Type} {f : A $-> B}
        `{IsEquiv A B f} : CatIsEquiv f.
@@ -134,6 +120,7 @@ Proof.
   - intros g h p x.
     exact (1 @@ p x).
   - intros ? ? ? ? ? ? ? ?; apply concat_p_pp.
+  - intros ? ? ? ? ? ? ? ?; apply concat_pp_p.
   - intros ? ? ? ?. apply concat_p1.
   - intros ? ? ? ?. apply concat_1p.
 Defined.
@@ -163,12 +150,21 @@ Defined.
 Global Instance is21cat_type : Is21Cat Type.
 Proof.
   snrapply Build_Is21Cat.
-  1-6: exact _.
-  - intros a b c d f g h i p x; cbn.
+  1-4, 6-7: exact _.
+  - intros a b c f g h k p q x; cbn.
+    symmetry.
+    apply concat_Ap.
+  - intros a b c d f g.
+    snrapply Build_Is1Natural.
+    intros h i p x; cbn.
     exact (concat_p1 _ @ ap_compose _ _ _ @ (concat_1p _)^).
-  - intros a b f g p x; cbn.
+  - intros a b.
+    snrapply Build_Is1Natural.
+    intros f g p x; cbn.
     exact (concat_p1 _ @ ap_idmap _ @ (concat_1p _)^).
-  - intros a b f g p x; cbn.
+  - intros a b.
+    snrapply Build_Is1Natural.
+    intros f g p x; cbn.
     exact (concat_p1 _ @ (concat_1p _)^).
   - reflexivity.
   - reflexivity.
diff --git a/theories/WildCat/Yoneda.v b/theories/WildCat/Yoneda.v
index faf01c0e25b..4af6d842b20 100644
--- a/theories/WildCat/Yoneda.v
+++ b/theories/WildCat/Yoneda.v
@@ -8,6 +8,7 @@ Require Import WildCat.Opposite.
 Require Import WildCat.FunctorCat.
 Require Import WildCat.NatTrans.
 Require Import WildCat.Prod.
+Require Import WildCat.Bifunctor.
 Require Import WildCat.ZeroGroupoid.
 
 (** ** Two-variable hom-functors *)
@@ -42,6 +43,22 @@ Proof.
     refine (cat_assoc_opp _ _ _).
 Defined.
 
+Global Instance is0bifunctor_hom {A} `{Is01Cat A}
+  : Is0Bifunctor (A:=A^op) (B:=A) (C:=Type) (@Hom A _).
+Proof.
+  nrapply Build_Is0Bifunctor'.
+  1-2: exact _.
+  exact is0functor_hom.
+Defined.
+
+(** While it is possible to prove the bifunctor coherence condition from [Is1Cat_Strong], 1-functoriality requires morphism extensionality.*)
+Global Instance is1bifunctor_hom {A} `{Is1Cat A} `{HasMorExt A}
+  : Is1Bifunctor (A:=A^op) (B:=A) (C:=Type) (@Hom A _).
+Proof.
+  nrapply Build_Is1Bifunctor'.
+  exact is1functor_hom.
+Defined.
+
 Definition fun01_hom {A} `{Is01Cat A}
   : Fun01 (A^op * A) Type
   := @Build_Fun01 _ _ _ _ _ is0functor_hom.
@@ -53,6 +70,7 @@ Definition fun01_hom {A} `{Is01Cat A}
 Definition opyon {A : Type} `{IsGraph A} (a : A) : A -> Type
   := fun b => (a $-> b).
 
+(** We prove this explicitly instead of using the bifunctor instance above so that we can apply [fmap] in each argument independently without mapping an identity in the other. *)
 Global Instance is0functor_opyon {A : Type} `{Is01Cat A} (a : A)
   : Is0Functor (opyon a).
 Proof.
@@ -125,6 +143,7 @@ Global Instance is1natural_opyoneda {A : Type} `{Is1Cat A}
   (a : A) (F : A -> Type) `{!Is0Functor F, !Is1Functor F} (x : F a)
   : Is1Natural (opyon a) F (opyoneda a F x).
 Proof.
+  snrapply Build_Is1Natural.
   unfold opyon, opyoneda; intros b c f g; cbn in *.
   exact (fmap_comp F g f x).
 Defined.
@@ -219,6 +238,45 @@ Defined.
 Definition opyon_0gpd {A : Type} `{Is1Cat A} (a : A) : A -> ZeroGpd
   := fun b => Build_ZeroGpd (a $-> b) _ _ _.
 
+Global Instance is0functor_hom_0gpd {A : Type} `{Is1Cat A}
+  : Is0Functor (A:=A^op*A) (B:=ZeroGpd) (uncurry (opyon_0gpd (A:=A))).
+Proof.
+  nrapply Build_Is0Functor.
+  intros [a1 a2] [b1 b2] [f1 f2]; unfold op in *; cbn in *.
+  rapply (Build_Morphism_0Gpd (opyon_0gpd a1 a2) (opyon_0gpd b1 b2)
+          (cat_postcomp b1 f2 o cat_precomp a2 f1)).
+Defined.
+
+Global Instance is1functor_hom_0gpd {A : Type} `{Is1Cat A}
+  : Is1Functor (A:=A^op*A) (B:=ZeroGpd) (uncurry (opyon_0gpd (A:=A))).
+Proof.
+  nrapply Build_Is1Functor.
+  - intros [a1 a2] [b1 b2] [f1 f2] [g1 g2] [p q] h.
+    exact (h $@L p $@@ q).
+  - intros [a1 a2] h.
+    exact (cat_idl _ $@ cat_idr _).
+  - intros [a1 a2] [b1 b2] [c1 c2] [f1 f2] [g1 g2] h.
+    refine (cat_assoc _ _ _ $@ _).
+    refine (g2 $@L _).
+    refine (_ $@L (cat_assoc_opp _ _ _) $@ _).
+    exact (cat_assoc_opp _ _ _).
+Defined.
+
+Global Instance is0bifunctor_hom_0gpd {A : Type} `{Is1Cat A}
+  : Is0Bifunctor (A:=A^op) (B:=A) (C:=ZeroGpd) (opyon_0gpd (A:=A)).
+Proof.
+  snrapply Build_Is0Bifunctor'.
+  1,2: exact _.
+  exact is0functor_hom_0gpd.
+Defined.
+
+Global Instance is1bifunctor_hom_0gpd {A : Type} `{Is1Cat A}
+  : Is1Bifunctor (A:=A^op) (B:=A) (C:=ZeroGpd) (opyon_0gpd (A:=A)).
+Proof.
+  snrapply Build_Is1Bifunctor'.
+  exact is1functor_hom_0gpd.
+Defined.
+
 Global Instance is0functor_opyon_0gpd {A : Type} `{Is1Cat A} (a : A)
   : Is0Functor (opyon_0gpd a).
 Proof.
@@ -259,6 +317,7 @@ Global Instance is1natural_opyoneda_0gpd {A : Type} `{Is1Cat A}
   (a : A) (F : A -> ZeroGpd) `{!Is0Functor F, !Is1Functor F} (x : F a)
   : Is1Natural (opyon_0gpd a) F (opyoneda_0gpd a F x).
 Proof.
+  snrapply Build_Is1Natural.
   unfold opyon_0gpd, opyoneda_0gpd; intros b c f g; cbn in *.
   exact (fmap_comp F g f x).
 Defined.
diff --git a/theories/WildCat/ZeroGroupoid.v b/theories/WildCat/ZeroGroupoid.v
index 46263d0010e..ec60178e96a 100644
--- a/theories/WildCat/ZeroGroupoid.v
+++ b/theories/WildCat/ZeroGroupoid.v
@@ -1,5 +1,7 @@
-Require Import Basics.Overture Basics.Tactics.
-Require Import WildCat.Core WildCat.Equiv WildCat.EquivGpd WildCat.Prod.
+Require Import Basics.Overture Basics.Tactics
+               Basics.PathGroupoids.
+Require Import WildCat.Core WildCat.Equiv WildCat.EquivGpd
+               WildCat.Forall.
 
 (** * The wild 1-category of 0-groupoids. *)
 
@@ -9,7 +11,7 @@ Record ZeroGpd := {
   carrier :> Type;
   isgraph_carrier : IsGraph carrier;
   is01cat_carrier : Is01Cat carrier;
-  is0gpd_carrier : Is0Gpd carrier;  
+  is0gpd_carrier : Is0Gpd carrier;
 }.
 
 Global Existing Instance isgraph_carrier.
@@ -70,6 +72,7 @@ Proof.
     cbn.
     exact (p (f x)).
   - reflexivity. (* Associativity. *)
+  - reflexivity. (* Associativity in opposite direction. *)
   - reflexivity. (* Left identity. *)
   - reflexivity. (* Right identity. *)
 Defined.
@@ -139,18 +142,71 @@ Proof.
     apply e0.
 Defined.
 
-Definition prod_0gpd (G H : ZeroGpd) : ZeroGpd.
+(** [I]-indexed products for an [I]-indexed family of 0-groupoids. *)
+Definition prod_0gpd (I : Type) (G : I -> ZeroGpd) : ZeroGpd.
 Proof.
-  rapply (Build_ZeroGpd (G * H)).
+  rapply (Build_ZeroGpd (forall i, G i)).
 Defined.
 
-Definition prod_0gpd_corec {G H K : ZeroGpd} (f : G $-> H) (g : G $-> K)
-  : G $-> prod_0gpd H K.
+(** The [i]-th projection from the [I]-indexed product of 0-groupoids. *)
+Definition prod_0gpd_pr {I : Type} {G : I -> ZeroGpd}
+  : forall i, prod_0gpd I G $-> G i.
 Proof.
+  intros i.
   snrapply Build_Morphism_0Gpd.
-  1: exact (fun x => (f x, g x)).
+  1: exact (fun f => f i).
   snrapply Build_Is0Functor; cbn beta.
-  intros x y p; simpl; split.
-  - apply (fmap f p).
-  - apply (fmap g p).
+  intros f g p.
+  exact (p i).
+Defined.
+
+(** The universal property of the product of 0-groupoids holds almost definitionally. *)
+Definition equiv_prod_0gpd_corec {I : Type} {G : ZeroGpd} {H : I -> ZeroGpd}
+  : (forall i, G $-> H i) <~> (G $-> prod_0gpd I H).
+Proof.
+  snrapply Build_Equiv.
+  { intro f.
+    snrapply Build_Morphism_0Gpd.
+    1: exact (fun x i => f i x).
+    snrapply Build_Is0Functor; cbn beta.
+    intros x y p i; simpl.
+    exact (fmap (f i) p). }
+  snrapply Build_IsEquiv.
+  - intro f.
+    intros i.
+    exact (prod_0gpd_pr i $o f).
+  - intro f.
+    reflexivity.
+  - intro f.
+    reflexivity.
+  - reflexivity.
+Defined.
+
+(** Indexed products of groupoids with equivalent indices and fiberwise equivalent factors are equivalent. *)
+Definition cate_prod_0gpd {I J : Type} (ie : I <~> J)
+  (G : I -> ZeroGpd) (H : J -> ZeroGpd)
+  (f : forall (i : I), G i $<~> H (ie i))
+  : prod_0gpd I G $<~> prod_0gpd J H.
+Proof.
+  snrapply cate_adjointify.
+  - snrapply Build_Morphism_0Gpd.
+    + intros h j.
+      exact (transport H (eisretr ie j) (cate_fun (f (ie^-1 j)) (h _))).
+    + nrapply Build_Is0Functor.
+      intros g h p j.
+      destruct (eisretr ie j).
+      refine (_ $o Hom_path (transport_1 _ _)).
+      apply Build_Morphism_0Gpd.
+      exact (p _).
+  - exact (equiv_prod_0gpd_corec (fun i => (f i)^-1$ $o prod_0gpd_pr (ie i))).
+  - intros h j.
+    cbn.
+    destruct (eisretr ie j).
+    exact (cate_isretr (f _) _).
+  - intros g i.
+    cbn.
+    refine (_ $o Hom_path
+            (ap (cate_fun (f i)^-1$) (transport2 _ (eisadj ie i) _))).
+    destruct (eissect ie i).
+    exact (cate_issect (f _) _).
 Defined.
diff --git a/theories/dune b/theories/dune
index 154cd414ec1..7e307366606 100644
--- a/theories/dune
+++ b/theories/dune
@@ -6,7 +6,4 @@
 
 (coq.theory
  (name HoTT)
- (package coq-hott)
- (modules :standard)
- (flags -noinit -indices-matter -color on)
- (coqdoc_flags :standard --interpolate --utf8 --no-externals --parse-comments))
+ (package coq-hott))